AW: Übertragen v. Werten nach Gesamt Datei
23.02.2004 13:02:14
Y. Housein
Hallo Sepp,
ichh glaube mit dein Code landen alle Tabellen Daten nach Journal. Das ist aber nicht der gewünschte Ergebnis.
Ein Info zur Verständnis:
z.B. Die Datei Nürnberg.xls(Tabelle:Journal) nach Gesamt.xls(Tabelle:"Journal")
Die Datei Nürnberg.xls(Tabelle:Kunden) nach Gesamt.xls(Tabelle:"Kunden")
Die Datei Nürnberg.xls(Tabelle:Verkaufte Artikel) nach Gesamt.xls(Tabelle:"Verkaufte Artikel") usw.
Also nicht alle Tabellen sollen in Datei Gesamt.xls(Tabelle:"Journal") zusammengefasst werden.
Hier nochmal v. mir angepasste Code Version. Ist aber auch falsch und ferner bleibt es beim Next stehen.
Sub JournalSammeln()
'von Josef Ehrensberger
'Dieser Code gehört in ein allgemeines Modul in der Datei "Gesamt.xls"
'Wenn die Dateien "Datei1.xls" bis "Datei10.xls" in einem anderen
'Verzeichnis liegen, dann muss dieser Pfad angegeben werden!
'Z. B. : Workbooks.Open ("D:\Journale\Datei" & intC & ".xls")
'Bitte zuerst sicherungskopien der dateien anlegen!
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
'For intC = 1 To 4
'Application.StatusBar = "Öffne Datei " & intC & " ! Bitte warten"
'Workbooks.Open ("M:\Ismail\Touren\Datei" & intC & ".xls") 'Datei "Datei1.xls" öffnen 1-10
arFiles = Array("Ansbach.xls", "Aschaffenburg.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
'A Set wksD = ActiveWorkbook.Sheets("Journal") 'Tabelle "Journal"
For Each wksD In ActiveWorkbook.Sheets
If wksD.Name = "Journal" Or wksD.Name = "Verkaufte Artikel" _
Or wksD.Name = "Journal Gutschrift" Or wksD.Name = "Kunden" Then 'beliebig erweiterbar
' wurde ersetzt durch A
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"
'###### hier einfügen ???##########################################################
rngD.Copy wksG.Range("A" & lngG) 'Daten kopieren
' end if und next wird einfügt - wenn nötig löschen
End If
Next
Application.StatusBar = "Schliesse Datei " & intC & " ! Bitte warten"
Workbooks(arFiles(intC)).Close SaveChanges:=False 'Datei schliessen
Next
ERRORH: 'Fehlerbehandlung
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Gruß
Yilmaz