AW: XL4
14.12.2005 19:17:51
Erich
Hallo Rainer,
mit deinen Antworten sind sind wir jetzt schon ein ganzen Stück weiter - aber alle hast du doch nicht beantwortet:
Frage 1:
Die Frage war nicht, wo die Quelldateien liegen, sondern, wo es eine Liste der Queölldateien gibt.
Die Quelldateien-Liste wird jetzt dynamisch aufgebaut - aus ALLEN xls-Dateien in C:\Umsatz.
2. - neue Version:
In jeder Quelldatei stehen in Zeile 16 Spaltenüberschriften:
C16: "Werktage" (uninteressant)
D16 und rechts daneben "Umsatz ..." (unterschiedliche Anzahl, mindestens eine)
rechts daneben: Summe Umsatz (uninteressant)
rechts daneben: Personalkosten
3.
Die Überschriften, die mit "Umsatz" anfangen oder gleich "Personalkosten" sind, und die Tageswerte (AUCH DIE FORMATE ?) unter diesen Überschriften sollen in ein Mastersheet übertragen werden.
## Sollen AUCH DIE FORMATE übertragen werden? (ist jetzt so)
Folgendes Modul tut das:
Option Explicit
Sub Kopie_aus_Mappen()
Dim intSpZ%, intSp%
Dim wks As Worksheet, fs As FileSearch, ii%, lngLast&
' Vorgaben
Const strVerz = "c:\umsatz" ' Quellverzeichnis
Const lngZeQ = 16 ' Zeile mit Überschriften in Quelldateien
Const intSpQ = 4 ' 1. mögliche Quellspalte (Umsatz ...)
Const lngZeZ = 15 ' Zeile mit Überschriften in Zieldatei
intSpZ = 2 ' 1. Zielspalte
' Vorgaben Ende
Set wks = ActiveSheet
Set fs = Application.FileSearch
fs.NewSearch
fs.LookIn = strVerz
fs.Filename = "*.xls"
fs.SearchSubFolders = False
fs.MatchTextExactly = True
fs.FileType = msoFileTypeAllFiles
If fs.Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
For ii = 1 To fs.FoundFiles.Count
Workbooks.Open Filename:=fs.FoundFiles(ii), UpdateLinks:=False
intSp = intSpQ
While Left(Cells(lngZeQ, intSp), 6) = "Umsatz"
lngLast = Cells(lngZeQ, intSp).End(xlDown).Row
Range(Cells(lngZeQ, intSp), Cells(lngLast, intSp)).Copy _
Destination:=wks.Cells(lngZeZ, intSpZ)
intSpZ = intSpZ + 1
If intSpZ > Columns.Count Then
MsgBox "Spalten der Zieldatei reichen nicht aus."
Exit Sub
End If
intSp = intSp + 1
Wend
While Not IsEmpty(Cells(lngZeQ, intSp))
If Cells(lngZeQ, intSp) = "Personalkosten" Then
lngLast = Cells(lngZeQ, intSp).End(xlDown).Row
Range(Cells(lngZeQ, intSp), Cells(lngLast, intSp)).Copy _
Destination:=wks.Cells(lngZeZ, intSpZ)
intSpZ = intSpZ + 1
If intSpZ > Columns.Count Then
MsgBox "Spalten der Zieldatei reichen nicht aus."
Exit Sub
End If
End If
intSp = intSp + 1
Wend
ActiveWorkbook.Close False
Next ii
Else
MsgBox "Keine Dateien in '" & strVerz & "' gefunden!"
End If
End Sub
Die Master-Mappe habe ich mal beigefügt: https://www.herber.de/bbs/user/29267.xls
Nachbemerkung:
Warum antwortest du immer auf deinen eigenen und nicht auf meinen letzten Beitrag? Praktischer wäre, Fragen und Antworten zusammen auf einer Webseite zu sehen.
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort