VBA Excel Problem !

[Psychodelik]

Hallo grüner Planet,
ich bräuchte dringend mal eure Hilfe, bin leider am Ende mit meinem Latein !
Folgenden VBA Code habe ich geschrieben !

Public Sub Daten_mehrerer_Dateien_zusammenfuehren()
`Code für ein allgemeines Modul
On Error GoTo errExit
Dim WBQ As Workbook
Dim WBZ As Workbook
Dim varDateien As Variant
Dim IngLastQ As Long

Set WBZ = ActiveWorkbook
`Altdaten auf Zielblatt löschen
WBZ.Worksheets(1).Range(``A2:IV65536``).ClearContents

varDateien = _
Application.GetOpenFilename(``Datei (*.csv),*.csv``, False, ``Bitte gewünschte
Datei(en) markieren``, False, True)

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

For IngAnzahl = LBound(varDateien) To UBound(varDateien)
Set WBQ = Workbooks.Open(Filename:=varDateien(IngAnzahl))
IngLastQ = WBQ.Worksheets(1).Range``A65536``).End(xlUp).Row
WBQ.Worksheets(1).Range(``A2:z`` & IngLastQ).Copy _
Destination:=WBZ.Worksheets(1).Range(``A`` &
WBZ.Worksheets(1).Range(``A65536``).End(xlUp).Row + 1)
WBQ.Close
Next

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With

MsgBox ``Es wurden `` & UBound(varDateien) & `` Dateien zusammengefügt.``, 64

Exit Sub

errExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With

If Err.Numer = 13 Then
MsgBox ``Es wurde keine Datei ausgewählt``
Else
MsgBox ``Es ist ein Fehler aufgetreten!`` & vbCr _
& ``Fehlernummer: `` & Err.Number & vbCr _
& ``Fehlerbeschreibung: `` & Err.Description
End If

End Sub

Die Sachlage schildert sich folgendermaßen !
Ich möchte gerne mehrere kleine Excel Dateien in eine große einzelne Excel Datei zusammen fügen. So weit, so gut, es klappt ja auch tadellos, aber in der Spalte "BB" sind bei der zusammen gefügten Datei, die Datensätze verschwunden ! Alle anderen Spalten werden korrekt angezeigt, alle Datensätze sind vollständig vorhanden, nur die Spalte BB mit den jeweiligen Datensätze wird nicht angezeigt.

Was mache ich falsch ?

Habe ich irgend wo ein Schreibfehler beim VBA Code ?

Habe ich was übersehen ?

Bräuchte bitte dringend mal eure Hilfe.

Danke im voraus für eure Unterstützung.

Gruß

PSYCHO

 

[Psychodelik]

Als Ergänzung !

Hab da mal ein bißchen probiert und den Code leicht verändert, allerdings habe ich immer noch das Problem, das bei der Spalte BB (die Excel Datei ist in horizontaler Ebene sehr sehr lang !) die Datensätze NICHT angezeigt werden.

Bei der ursprünglichen Originaldatei sind die Datensätze in Spalte BB vorhanden, aber wenn ich alle Excel Dateien in eine einzige große Excel Datei einfüge, dann verschwinden die Datensätze in Spalte BB !

Bitte um HILFE !

Hier der neue leicht veränderte 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 (*.csv*), *.csv*", , , , 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, 5).Formula = _
"='" & sPfad & "[" & sDatei & "]Tabelle1'!A2"
Else
blnÜberschrift = True
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ, 5).Formula = _
"='" & sPfad & "[" & sDatei & "]Tabelle1'!A1"
End If
End With

Call StatusBalken(Int((i / UBound(vFileToOpen)) * 100))
Next

With Tabelle1.UsedRange
.Copy
.PasteSpecial xlPasteValues
.Rows(1).Delete
End With

ENDE:
Application.EnableEvents = True
Application.Calculation = iCalc
Application.ScreenUpdating = True
If Err Then MsgBox Err.Description, , "Fehler: " & Err
End Sub

Sub StatusBalken(ProzentSatz) ''ProzentSatz = Int((i / 10000) * 100)
Dim Mess, Z, Rest
Static oldStatusBar As Integer
Static blnInit As Boolean

If Not blnInit Then
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
End If

Mess = ""
For Z = 1 To ProzentSatz
Mess = Mess & ChrW(Val("&H25A0"))
Next Z
Rest = 100 - ProzentSatz
For Z = 1 To Rest
Mess = Mess & ChrW(Val("&H25A1"))
Next Z
Application.StatusBar = Mess & " " & ProzentSatz & "%"

If Rest <= 0 Then
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
End If
End Sub