Code Anpassung
20.02.2004 16:19:11
Y. Housein
welchen Code muss ich hinzufügen, wenn ich die noch Werte von anderen Tabellen kopieren möchte. Im moment wird nur die Tabelle "Journal" kopiert. Ich möchte folgende Tabellen noch hinzufügen: "Verkaufte Artikel", "Verkaufte Artikel-Normal".
Sub JournalSammeln()
'von Josef Ehrensberger
Dim wkbGes As Workbook 'Die Gesamt - Datei
Dim wksG As Worksheet
Dim wksD As Worksheet
Dim rngD As Range
Dim lngG As Long
Dim lngD As Long
Dim intC As Integer
'On Error GoTo ERRORH
Dim arFiles As Variant
Set wkbGes = Workbooks("Gesamt.xls") 'Name der Gesamtdatei
Set wksG = wkbGes.Sheets("Journal") 'Name des Tabellenblattes für Gesammt-Journal
Application.ScreenUpdating = False
arFiles = Array("Ansbach.xls", "Anschaffenburg.xls", "Augsburg.xls", "Coburg.xls", _
"Erlangen.xls", "Gingen.xls", "Heidenheim.xls", "Heilbronn.xls", _
"Ingolstadt.xls", "Kempten.xls", "München-01.xls", "München-02.xls", _
"Nürnberg-01.xls", "Nürnberg-02.xls", "Pforzheim Karlsruhe.xls", _
"Regensburg.xls", "Stuttgart.xls", "Ulm.xls", "Würzburg.xls") 'dieses Array beliebig mit den Dateinamen erweitern
For intC = LBound(arFiles) To UBound(arFiles)
Application.StatusBar = "Öffne Datei " & arFiles(intC) & " ! Bitte warten"
Workbooks.Open ("M:\Ismail\Touren\" & arFiles(intC)) 'Datei aus Array öffnen
Set wksD = ActiveWorkbook.Sheets("Journal") 'Tabelle "Journal"
lngG = wksG.Range("A65536").End(xlUp).Row + 1 'erste freie Zelle in "Gesammt"
lngD = wksD.Range("A65536").End(xlUp).Row 'Grösse des Bereiches bestimmen
If lngD < 10 Then lngD = 10
Set rngD = wksD.Range("A10:Z" & lngD)
Application.StatusBar = "Kopiere Daten! Bitte warten"
rngD.Copy wksG.Range("A" & lngG) 'Daten kopieren
Application.StatusBar = "Schliesse Datei " & intC & " ! Bitte warten"
Workbooks(arFiles(intC)).Close savechanges:=False 'Datei schliessen
'ActiveWorkbook.Close ("M:\Ismail\Touren\" & arFiles(intC))
Next
ERRORH: 'Fehlerbehandlung
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Danke für die Hilfe
Gruß
Yilmaz