Tabellenumbau - spaltendurchlauf mit for?
16.10.2008 08:51:36
Reptil
ich habe, dank diesem forum ;-), ein makro, welches mir aus vielen exceldateien eine "sammeldatei" mit allen benötigten daten generiert. nun hat sich jedoch eine anforderung geändert, wodurch der aufbau der tabelle nicht so bleiben kann....
bisher sieht die tabelle folgendermaßen aus:
jahr|fabrikname|kostenstelle|einheit|kostenart|januar|februar|.....|dezember|summe
für die neue anforderung wäre jedoch folgender aufbau nötig:
Jahr|monat|fabrikname|kostenstelle|einheit|kostenart
die summe würde nicht zwingend benötigt.
die sub, die bisher für das zusammenführen nötig war sieht aus wie folgt:
Sub Zusammenführen_in_eine_Tabelle(Verzeichnis As String)
' Führt die Daten aus den Dateien in Verzeichnis in einer Datei zusammen
' Daten aus der 1. Tabelle in den Quell-Dateien werden in die Ziel-Tabelle übertragen
Dim wbQuelle As Workbook, wksQuelle As Worksheet
Dim intI As Integer, Zeile As Long
Dim objFileSearch As FileSearch
Dim löschen As Range
Set objFileSearch = Application.FileSearch
With objFileSearch
'Exceldateien im Verzeichnis suchen
.NewSearch
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
.LookIn = Verzeichnis
If .Execute > 0 Then
For intI = 1 To .FoundFiles.Count
Application.StatusBar = "Datei " & .FoundFiles(intI) & " wird bearbeitet"
'Quelldatei öfnen
Set wbQuelle = Workbooks.Open(FileName:=.FoundFiles(intI), ReadOnly:=True)
'Quelltabelle setzen = 1. Tabellenblatt in Quelldatei
Set wksQuelle = wbQuelle.Worksheets(1)
'Daten aus Quelltabelle in Zieltabelle übertragen
With wksQuelle
If bolTitelzeile = False Then
'Bei 1. Datei aus der Zeile 13 die Spaltentitel (C-O) in die Zeile 2 der _
Ziel-Tabelle übertragen
wksZiel.Range(wksZiel.Cells(2, 5), wksZiel.Cells(2, 17)).Value = _
.Range(.Cells(13, 2), .Cells(13, 15)).Value
bolTitelzeile = True
End If
wksZiel.Cells(ZeileDaten, 3) = wbQuelle.Name 'Name Quelldatei
Select Case wbQuelle.Name 'Vergleicht den Namen der Quelldateien mit der _
Liste(unten).
'füllt die spalte "fabrikname", hier nicht genau aufgeführt
End Select
For Each löschen In wksZiel.Cells(ZeileDaten, 3)
löschen = Left(löschen, Len(löschen) - 4)
Next
wksZiel.Cells(ZeileDaten, 1) = Year(Date)
wksZiel.Cells(ZeileDaten, 2) = Firmenname 'Firmenname
wksZiel.Cells(ZeileDaten, 4) = fncABC_P(.Range("B9").Text) 'Beschreibungstext
wksZiel.Cells(ZeileDaten, 5) = fncKST(.Range("B10").Text) 'Kostenstelle
'letzte Zeile mit Summe in Spalte B ermitteln
Zeile = .Cells(.Rows.Count, 3).End(xlUp).Row
'Daten aus Summenzeile Spalten C bis O übertragen
wksZiel.Range(wksZiel.Cells(ZeileDaten, 6), wksZiel.Cells(ZeileDaten, 18)).Value = _
.Range(.Cells(Zeile, 3), .Cells(Zeile, 15)).Value
ZeileDaten = ZeileDaten + 1
End With
wbQuelle.Close Savechanges:=False
Next
Application.StatusBar = False
End If
End With
End Sub
meine idee war jetzt, bei dem punkt
'Daten aus Summenzeile Spalten C bis O übertragen
wksZiel.Range(wksZiel.Cells(ZeileDaten, 6), wksZiel.Cells(ZeileDaten, 18)).Value = _
.Range(.Cells(Zeile, 3), .Cells(Zeile, 15)).Value
eine for schleife einzubauen, die die spalten der quelldatei einzeln durchläuft und dann eben die einzelnen werte untereinander und nicht nebeneinander einträgt.
hier ist noch eine dummydatei, wie die quelldateien aussehen:
https://www.herber.de/bbs/user/56051.xls
ich hoffe, es kann mir jemand helfen : /
grüße