VBA - Zellen in Master-Datei konsuldieren
05.12.2023 08:39:19
Ruhrpottriot
ich verzweifle gerade wieder an einem VBA-Problem, mit dem ich einfach nicht weiter komme. Ich benötige einen Excel-Code, der einen Zellbereich (E12:K36) aus mehreren, gleich aufgebauten Excel-Dateien und Tabellenblättern (ist immer das Tabellenblatt mit dem Namen "45"), die sich in einem Ordner befinden, zusammenfasst/untereinander kopiert. Es gibt relativ viele solcher VBA-Module im Netz, aber ich habe keines gefunden, dass alle Dateien eines Pfades durchsucht und die alten Werte gleichzeitig löscht. Ich habe schon versucht mir den unten stehenden Code anzupassen, aber ich kann es einfach nicht...
Könnte mir jemand helfen. In dem folgendem Code müssten zwei Dinge angepasst werden:
1. Die Dateien sollen nicht ausgewählt werden, sondern es sollen automatisch die Dateien eines bestimmten Pfades angepasst werden
2. Der Zellbereich soll jeweils E12:K36 vom Tabellenblatt 45 (45 ist der Name des Blattes) sein. Das kann ich auch selber versuchen anzupassen, ich habe nur leider keine Ahnung wo...
Das Makro kommt aus diesem Beitrag: https://www.herber.de/forum/archiv/1576to1580/1578467_Tabellen_aus_mehreren_Dateien_zusammenfuehren.html
Modul 1:
Option Explicit
'von Josef Ehrenberger
'siehe: http://www.herber.de/forum/archiv/1260to1264/1260766_Letzte_Zeile_aus_geschlossene_Excel_Datei.html
Function lastRowClosedFile(ByVal FileName As String, SheetName As String, TargetRange As String) As Long
Dim objADO As Object
On Error Resume Next
Set objADO = ExcelTable(FileName, SheetName, TargetRange)
lastRowClosedFile = objADO.RecordCount + 1
objADO.Close
End Function
Private Function ExcelTable(ByRef Path As String, ByRef Table As String, ByRef SourceRange As String) As Object
Dim SQL As String
Dim Con As String
SQL = "select * from [" & Table & "$" & SourceRange & "]"
If Mid(Path, InStrRev(Path, ".") + 1) = "xls" Then
Con = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Extended Properties=Excel 8.0;" _
& "Data Source=" & Path & ";"
ElseIf Mid(Path, InStrRev(Path, ".") + 1) Like "xls?" Then
Con = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Extended Properties=""Excel 12.0;HDR=YES"";" _
& "Data Source=" & Path & ";"
Else
Exit Function
End If
Set ExcelTable = CreateObject("ADODB.Recordset")
ExcelTable.Open SQL, Con, 3, 1
End Function
Modul 2:
Function GetConnXLS(ByVal cFileName As String, _
Optional ByVal InformErrMSG As Boolean = False) As ADODB.Connection
'On Error GoTo LOI:
'Open ADO connection to excel workbook
Dim oConn As ADODB.Connection
Dim Ext As String, ConnStr As String
Set oConn = New ADODB.Connection
ConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & cFileName & ";" & _
"Extended Properties=""Excel 12.0 xml;HDR=Yes"";"
oConn.Open ConnStr
Set GetConnXLS = oConn
Exit Function
LOI:
If Err.Number > 0 Then
Set oConn = Nothing
If InformErrMSG Then
MsgBox "GetConnXLS" & ": " & Err.Number & " " & Err.Description, vbCritical
End If
End If
End Function
Sub Merge_All()
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sh As Worksheet
Dim I As Long, k As Long, CountFiles As Long, J As Long, strData, _
kDS As Long, xKorr As Integer
files = Application.GetOpenFilename(, , , , True)
If VarType(files) = vbBoolean Then Exit Sub
Set sh = Sheets("Master")
For k = LBound(files) To UBound(files)
'Anzahl der Datensätze in der ausgewählten DAtei ermitteln
kDS = lastRowClosedFile(files(k), "Tabelle1", "A:A")
'ADODB-Connection erstellen
Set cnn = GetConnXLS(files(k))
If cnn Is Nothing Then
MsgBox "Check lai co so du lieu file: " & files(k)
Exit Sub
End If
'Select-Befehl zusammenstellen
strData = "SELECT * From [Tabelle1$A1:H" & kDS & "];"
'Recordset öffnen auf der Grundlage der Connection & Select-Befehl
Set rst = cnn.Execute(strData)
CountFiles = CountFiles + 1
If CountFiles = 1 Then
For J = 0 To rst.Fields.Count - 1
sh.Cells(3, J + 1).Value = rst.Fields(J).Name
Next J
End If
If k = 1 Then
xKorr = 1
Else
xKorr = 0
End If
sh.Range("I" & 4 + I - xKorr).Value = files(k)
I = I + sh.Range("A" & 4 + I).CopyFromRecordset(rst)
rst.Close
Set rst = Nothing
cnn.Close
Set cnn = Nothing
Next k
MsgBox "Done", vbSystemModal + 48, "Hurraaa..."
End Sub
Habt ihr einen Tipp oder eine Internetseite für mich, wo ich mich in VBA einlesen kann. Ich merke zunehmend, dass ich vor Problemen stehe, die ich mit den Excel-eigenen Ressourcen nicht bewältigt bekomme...
Vielen Dank!!
Tim