Viele Datein, eine Zeile zusammenfügen
14.06.2021 17:31:31
Kathr
ich scheitere an folgendem Problem:
Ziel ist es, eine Datenbank aufzubauen, die aus vielen Excel-Dateien (*xlsm) die genau gleich aufgebaut sind immer von einem Tabellenblatt eine Zeile in eine andere Datei zieht und dort in der nächsten freien Zeile speichert. So möchte ich langfristig das ständige copy pasten vermeiden.
Mit Hilfe verschiedener Foren habe ich mir folgenden Code gebastelt (ja, gebastelt trifft es aufgrund gefährlichem Halbwissens). Ich weiß nicht, ob es theoretisch funktioniert und bekomme aber konkret auch immer einen "Loop ohne Do" Fehler angezeigt. Ich habe schon viel im Forum gesucht, aber keine Antwort gefunden. Ich danke euch schon mal ganz doll!
Public Sub Aus_Datei_Lesen()
Dim lngColumn As Long
Dim strDateiPfad As String
Dim objDateiSuche As Object
Dim intAnzahlDateien As Integer
Dim strDateiName As String
Dim strTabelleName As String
Dim strBereich As String
Dim wksBlatt As Worksheet
Dim lngLetzteZeile As Long
On Error GoTo Aus_Datei_Lesen_Error
strDateiPfad = "H:\XX\" 'Ordnerpfad
strTabelleName = "Database" 'Name des Tabellenblatts
strBereich = "A2:AF2" 'zu kopierender Bereich
strBereich = Range(strBereich).Address(RowAbsolute:=True, ColumnAbsolute:=True, ReferenceStyle:=xlR1C1)
Set wksBlatt = ThisWorkbook.Worksheets("Tabelle1")
With wksBlatt
If wksBlatt.Range("A65536") = "" Then lngLetzteZeile = wksBlatt.Range("A65536").End(xlUp).Row
lngColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
Set objDateiSuche = Application.FileSearch
With objDateiSuche
.NewSearch
.LookIn = strDateiPfad
.SearchSubFolders = False
.FileType = msoFileTypeAllFiles
.Filename = "*.xlsm"
If .Execute() > 0 Then
strDateiName = Dir(strDateiPfad & "*.xlsm")
Do While strDateiName ""
For intAnzahlDateien = 1 To .FoundFiles.Count
strDateiName = Dir(.FoundFiles(intAnzahlDateien))
If strDateiName ThisWorkbook.Name Then
With wksBlatt.Cells(lngLetzteZeile, lngColumn)
.Formula = "='" & strDateiPfad & "[" & strDateiName & "]" & strTabelleName & "'!" & strBereich
.Value = .Value
lngLetzteZeile = lngLetzteZeile + 1
End With
End If
strDateiName = Dir
Loop
Next intAnzahlDateien
End If
End With
Set objDateiSuche = Nothing
Set wksBlatt = Nothing
On Error GoTo 0
Exit Sub
Aus_Datei_Lesen_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Set objDateiSuche = Nothing
Set wksBlatt = Nothing
End Sub