|
Hallo zusammen,
ich nutze den unten beigefügten Code um aus verschiedenen Excel-Dateien den Inhalt auszulesen und in eine neue Datei zu kopieren. Klappt erstmal ganz gut.
[code]Sub Zusammenführen()
Sub auto_open ()
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("A6")
.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, 50).Formula = _
"=IF('" & sPfad & "[" & sDatei & "]Tabelle1'!A2="""","""",'" & sPfad & "[" & sDatei & "]Tabelle1'!A2)"
Else
blnÜberschrift = True
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ, 50).Formula = _
"=IF('" & sPfad & "[" & sDatei & "]Tabelle1'!A1="""","""",'" & 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
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\skrueger\Desktop\Projekt\Gesamt.xlsm", FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Range("A1").Select
End Sub[/code]
Und möchte/muss ihn etwas an meine Bedürfnisse anpassen.
1. die Spaltenüberschriften sind in allen Dateien gleich, wenn ich eine vorgefertigte Tabelle bereits habe soll er mir die Tabelleninhalte ohne Überschriften kopieren und zwar dann in das erste leere Feld unterhalb der Spaltenüberschrift.
2. ich möchte es erreichen das das Makro automatisch beim Öffnen der Datei abläuft und gleich in den Inhalt der 4 Excel-Dateien ausliest.
3. am schönsten ware es natürlich wenn er dann auch gleich die entsprechenden Feldformatierungen aus den Excel-Dateien übernimmt (sprich da wo vorher ein Datum stand soll er natürlich nach dem zusammenführen auch den Wert als Datum anzeigen)
ich arbeite mit Excel 2013
vorhandene Dateien:
1x Gesamt.xlsx
dann noch 1x user1.xlsx , 1x user2.xlsx , 1x user3.xslx und dann user4.xlsx
die Anzahl und die Bezeichnung der Dateien bleibt immer gleich. Die Gesamt.xlsx soll der Auswertung dienen. Alle Dateien sollen aus einem SharePoint liegen, wobei die User-Dateien in einem Unterordner "user" liegen.
Vielleicht gibt es jemanden der mir bei meinen Problemen weiter helfen kann :)
Grüsse
Sven
|