Tabellennamen definieren
23.03.2015 12:43:32
Sebastian
habe einen Makro-Code, der mehrere Exceldateien zusammenführt. Alles funktioniert sehr gut, jedoch erhalte ich jedes mal die Abfrage, dass das Tabellenblatt 1 nicht gefunden wurde, da das Blatt den Namen "Daten" enthält. Von Excel erhalte ich dann die Meldung: "Wählen Sie das Tabellenblatt aus, in dem sich die Quelle der zu aktualisierenden daten befindet."
Bei 50 Dateien ist das natürlich sehr mühselig jedes mal das Blatt auszuwählen...
Wie kann ich diese Meldung umgehen, damit er sofort das Tabellenblatt "Daten" wählt?
Anbei der Code:
Sub Zusammenführen()
Dim i As Long
Dim sPfad As String
Dim sDatei As String
Dim vFileToOpen As Variant
Dim lngLZ As Long
Dim blnÜberschrift As Boolean
Dim iCalc As Integer
vFileToOpen = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , , , True)
If Not IsArray(vFileToOpen) Then Exit Sub
iCalc = Application.Calculation
On Error GoTo ENDE:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
For i = 1 To UBound(vFileToOpen)
sDatei = Dir(vFileToOpen(i))
sPfad = Left(vFileToOpen(i), InStr(vFileToOpen(i), sDatei) - 1)
With Tabelle1.Range("A1")
.Formula = "=LOOKUP(2,1/('" & sPfad & "[" & sDatei & "]Tabelle1'!$A:$A""""),ROW('" _
_
& sPfad & "\[" & sDatei & "]Tabelle1'!$A:$A))"
lngLZ = .Value
End With
With Tabelle1
If blnÜberschrift Then
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ - 1, 47).Formula = _
"=IF('" & sPfad & "[" & sDatei & "]Tabelle1'!A8="""","""",'" & sPfad & "[" & _
sDatei & "]Tabelle1'!A8)"
Else
blnÜberschrift = True
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ, 47).Formula = _
"=IF('" & sPfad & "[" & sDatei & "]Tabelle1'!A6="""","""",'" & sPfad & "[" & _
sDatei & "]Tabelle1'!A6)"
End If
End With
Call StatusBalken(Int((i / UBound(vFileToOpen)) * 100))
Next
With Tabelle1.UsedRange
.Copy
.PasteSpecial xlPasteValues
.Rows(1).Delete
End With
Call Leerzeilen_loeschen
ENDE:
Application.EnableEvents = True
Application.Calculation = iCalc
Application.ScreenUpdating = True
If Err Then MsgBox Err.Description, , "Fehler: " & Err
End Sub
Vielen Dank schon mal im Voraus!