midivirus
Goto Top

Excel - Dateien zusammenfassen zusammenführen - untereinander - gleicher Ordner

Exceldateien ... in eine!

Moin,

ich stand vor dem Problem, dass wir immer Datenbankauszüge in Form einer Excel (XLS) Datei zugeschickt bekommen.
Diese beinhalten nur eine Arbeitsmappe und gleiche Überschriften.

Wenn jetzt ein Projekt mal 13 oder 14 Dateien beinhaltet, dann wird das schon langweilig, da jede Datei geöffnet, der Bereich markiert und copy/paste gemacht werden müsste.

Hab mich dann im Web auf die Suche gemacht und siehe da, möchte es auch zeigen:


 
Sub makro1()
Worksheets(1).Activate
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select  
aname = ActiveWorkbook.Name

Cells(1, 2) = "ID"  
Cells(1, 3) = "Nummer"  

pfad1 = ActiveWorkbook.Path & "\"              
name1 = Dir(pfad1, vbNormal)                  

Do While name1 <> ""                            
    If name1 <> aname Then                   
        If Right(name1, 4) = ".xls" Then         
            GoSub uebernehmen
        End If
    End If
    name1 = Dir                                
Loop
    Cells.Select                               
    Cells.EntireColumn.AutoFit                 
    Cells(1, 1).Select                        
Exit Sub                                      

uebernehmen:
Workbooks.Open Filename:=pfad1 & name1
Worksheets(1).Activate
lz = Range("b65536").End(xlUp).Row               
If lz > 1 Then
    Range(Cells(2, 2), Cells(lz, 18)).Select      
    Selection.Copy                                
    Windows(aname).Activate                       
    l1 = Range("a65536").End(xlUp).Row + 1           
    Cells(l1, 2).Activate                          
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False                
    Application.DisplayAlerts = False              
    Windows(name1).Close                          
    Application.DisplayAlerts = True             
    l2 = Range("b65536").End(xlUp).Row              
    Range(Cells(l1, 1), Cells(l2, 1)) = name1   
   
    Else
    Windows(name1).Close                           
End If
Return                                         
End Sub


Alle Dateien müssen in einem Ordner liegen, wo auch dieses Makro abgelegt ist.

Viel Spaß!

Content-Key: 141027

Url: https://administrator.de/contentid/141027

Ausgedruckt am: 28.03.2024 um 20:03 Uhr

Mitglied: Midivirus
Midivirus 18.05.2010 um 14:54:42 Uhr
Goto Top
782mal gelesen ... sehr interessant!
Mitglied: Jacksoney
Jacksoney 25.11.2010 um 17:28:18 Uhr
Goto Top
Hallo,
Ich bin nicht so fit in sachen VBA. Ich habe den Code als Test 1:1 kopiert und die Datei zeigt mir zwar die Überschrifften an jedoch keine Daten untereinander. die Daten jedoch erscheinen für einen Bruchteil einer Sekunde. woran kann das liegen?