AW: SummeWenn mehrere Dateien
16.12.2008 13:49:00
fcs
Hallo Christian,
die Zeilen sind im Code fest vorgegen. Damit es etwas einfacher anzupassen ist, hab ich entsprechende Konstanten deklariert, die du ggf. anpassen muss.
Die Überschriften der Spalten ändern sich ja nicht, die muss du "nur" einmalig im Zieltabellenblatt ("Daten") eintragen. Kannst du aber auch vom Makro machen lassen, wie in meinem Beispiel.
Im Makro werden die zu kopieren Spalten über die Nummern festgelegt, nicht über die Namen. Da ja der Aufbau deiner Quelldaten-Tabellen identisch ist, kann man das so machen.
Die Zeile im Code ist:
'Array mit Nummern der zu Kopierenden Spalten
arrSpalten = Array(1, 2, 7, 8, 9)
1 = A, 2 = B, 7 = G usw.
Hier muss du die Nummern entsprechend ergänzen, ändern.
Nachfolgend der angepasste Code, geänderte/neue Zeilen sind mit ### markiert.
Gruß
Franz
Sub DatenHolen()
Dim wksData As Worksheet
Dim strdatei As String, lngZeile As Long
Const StartZeile As Long = 2 'Zeile im Blatt Daten ab der Werte eingetragen werden sollen ### _
neu
On Error GoTo Fehler
Set wksData = Worksheets("Daten")
With wksData
'Spaltentitel eintragen '###
.Cells(1, 1) = "AuftragsNr." '###
.Cells(1, 2) = "Feld02" '###
.Cells(1, 3) = "Feld07" '###
.Cells(1, 4) = "Teilsumme" '###
.Cells(1, 5) = "Feld08" '###
.Cells(1, 6) = "Datei" '###
.Cells(1, 7) = "Blatt" '###
'Altdaten löschen
lngZeile = .Cells.SpecialCells(xlCellTypeLastCell).Row
If lngZeile >= StartZeile Then '#####
.Range(.Rows(StartZeile), .Rows(lngZeile)).ClearContents '#####
End If
End With
Application.Calculation = xlCalculationManual
'Startzeile für das Einfügen, nächste freie Zeile in Spalte 1 (A)
Application.ScreenUpdating = False
With wksData
lngZeile = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
strdatei = "C:\Lokale daten\Test\Daten\DateiNr1.xls"
Call AllesEinlesen(strdatei, wksData, lngZeile)
strdatei = "C:\Lokale daten\Test\Daten\DateiNr2.xls"
'Startzeile für das Einfügen, nächste freie Zeile in Spalte 1 (A)
With wksData
lngZeile = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
Call AllesEinlesen(strdatei, wksData, lngZeile)
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Alles eingelesen!"
Fehler:
With Err
If Err 0 Then
MsgBox "Fehler-nr.: " & .Number & vbLf & .Description
End If
End With
End Sub
Function AllesEinlesen(strDateiname As String, wksZiel As Worksheet, _
ZeileStart As Long) As Boolean
Dim Bereich As Range, wksQuelle As Worksheet, wbQuelle As Workbook
Dim ZeileZiel As Long, lngZeile As Long, arrSpalten, intSpalte As Integer, intI As Integer
Const StartDaten = 7 '1. Zeile mit Daten in den Quelltabellenblättern '#####
On Error GoTo Fehler
AllesEinlesen = True
Set wbQuelle = Workbooks.Open(Filename:=strDateiname, ReadOnly:=True)
ZeileZiel = ZeileStart
'Array mit Nummern der zu Kopierenden Spalten
arrSpalten = Array(1, 2, 7, 8, 9)
For Each wksQuelle In wbQuelle.Worksheets
Select Case wksQuelle.Name
Case "TabelleXYZ"
'do nothing, diese Tabellen sollen nicht ausgewertet werden
Case Else
intSpalte = 0 'Spaltenzähler in Zieltabelle
With wksQuelle
'letzte ausgefüllte Zeile in Spalte 1 (A)
lngZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
If lngZeile >= StartDaten Then
For intI = LBound(arrSpalten) To UBound(arrSpalten)
'Zellen mit Daten Bereich zuweisen
Set Bereich = .Range(.Cells(StartDaten, arrSpalten(intI)), _
.Cells(lngZeile, arrSpalten(intI)))
With wksZiel
Bereich.Copy
intSpalte = intSpalte + 1
.Cells(ZeileZiel, intSpalte).PasteSpecial Paste:=xlPasteValues
End With
Next
'Quelldatei und Tabelle eintragen
With wksZiel
intSpalte = intSpalte + 1
.Range(.Cells(ZeileZiel, intSpalte), _
.Cells(ZeileZiel + Bereich.Rows.Count - 1, intSpalte)).Value _
= wbQuelle.Name '###
intSpalte = intSpalte + 1
.Range(.Cells(ZeileZiel, intSpalte), _
.Cells(ZeileZiel + Bereich.Rows.Count - 1, intSpalte)).Value _
= wksQuelle.Name '###
End With
ZeileZiel = ZeileZiel + Bereich.Rows.Count
End If
End With
End Select
Next
Fehler:
With Err
If Err 0 Then
AllesEinlesen = False
MsgBox "Fehler-nr.: " & .Number & vbLf & .Description
End If
End With
If Not wbQuelle Is Nothing Then wbQuelle.Close savechanges:=False
End Function