Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1740to1744
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Daten ähnlicher Dateien zusammenführen

Daten ähnlicher Dateien zusammenführen
28.02.2020 08:41:38
Jan
Hallo liebe VBA-Profis,
ich habe folgendes Problem:
Ich habe verschiedene .xlsx-Dateien, die alle gleich heißen und sich nur durch eine dreistellige Nummer am Anfang des Dateinamens unterscheiden. Diese Nummern gehen von 101 bis 410, sind zwar fortlaufend, aber es fehlen viele zwischendrin. In diesen Dateien möchte ich jeweils von einem Arbeitsblatt, das immer denselben Namen hat, alle gefüllten Zeilen bis auf die erste (Überschriften) kopieren. Diese möchte ich dann in einer anderen Datei in einem Arbeitsblatt fortlaufend untereinander einfügen.
Ich hoffe, ihr könnt mir dabei helfen. :)
Falls Ihr noch irgendwelche Infos braucht, sagt gerne Bescheid!
Viele Grüße,
Jan

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Daten ähnlicher Dateien zusammenführen
28.02.2020 08:52:41
SF
Hola,
verlinkst du bitte deine Fragen in den verschiedenen Foren gegenseitig?
Danke.
Gruß,
steve1da
AW: Daten ähnlicher Dateien zusammenführen
28.02.2020 09:19:51
Jan
Die Zeilen, die kopiert werden sollen, sind fortlaufend gefüllt. Es kann höchstens sein, dass in den Zellen nachher Formeln stehen, die "" zurückliefern und die Zelle sehalb leer ist.
AW: Daten ähnlicher Dateien zusammenführen
28.02.2020 10:56:37
UweD
Hallo
so ?
Option Explicit

Sub alle_Dateien_Verzeichnis2() ' 
    On Error GoTo Fehler
    Dim WB As Workbook, TBx As Worksheet, Pfad As String, Ext As String, Datei As String, LRx As Long, LR0 As Long
    Dim ZTB As String
    
    Ext = "*.xlsx"
    Pfad = "X:\Temp\Test\" '**** mit \ 
    
    ZTB = "Quelle" 'Name des Blattes, aus dem gelesen wird 
    
    'Reset 
    With ActiveWorkbook.Sheets("Tabelle1")
        .UsedRange.ClearContents
        
        Datei = Dir(Pfad & Ext)
        Do While Len(Datei) > 0
            If IsNumeric(Left(Datei, 3)) Then
            
                Set WB = Workbooks.Open(Filename:=Pfad & Datei)
                Set TBx = WB.Sheets(ZTB)
                
                LR0 = .Cells.SpecialCells(xlCellTypeLastCell).Row   'Letzte Zeile des gesamten Blattes 
                LRx = TBx.Cells.SpecialCells(xlCellTypeLastCell).Row
                          
                TBx.Rows(2).Resize(LRx - 1).Copy .Rows(LR0 + 1)
                
                Workbooks(Datei).Close False
                
            End If
            Datei = Dir() ' nächste Datei 
        Loop
    End With
        
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear

End Sub

LG UweD
Anzeige
AW: Daten ähnlicher Dateien zusammenführen
28.02.2020 11:17:22
Jan
Berücksichtigt der Code auch die Nummern von 101 bis 410?
AW: Daten ähnlicher Dateien zusammenführen
28.02.2020 13:57:38
UweD
Hi
mit dieser Ergänzung jetzt ja.
Sub alle_Dateien_Verzeichnis2() ' 
    On Error GoTo Fehler
    Dim WB As Workbook, TBx As Worksheet, Pfad As String, Ext As String, Datei As String, LRx As Long, LR0 As Long
    Dim ZTB As String, Nummer As Variant
    
    Ext = "*.xlsx"
    Pfad = "X:\Temp\Test\" '**** mit \ 
    
    ZTB = "Quelle" 'Name des Blattes, aus dem gelesen wird 
    
    'Reset 
    With ActiveWorkbook.Sheets("Tabelle1")
        .UsedRange.ClearContents
        
        Datei = Dir(Pfad & Ext)
        Do While Len(Datei) > 0
            Nummer = Left(Datei, 3)
            If IsNumeric(Nummer) And Nummer >= 101 And Nummer <= 410 Then
            
                Set WB = Workbooks.Open(Filename:=Pfad & Datei)
                Set TBx = WB.Sheets(ZTB)
                
                LR0 = .Cells.SpecialCells(xlCellTypeLastCell).Row   'Letzte Zeile des gesamten Blattes 
                LRx = TBx.Cells.SpecialCells(xlCellTypeLastCell).Row
                          
                TBx.Rows(2).Resize(LRx - 1).Copy .Rows(LR0 + 1)
                
                Workbooks(Datei).Close False
                
            End If
            Datei = Dir() ' nächste Datei 
        Loop
    End With
        
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear

End Sub

LG UweD
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige