AW: Daten zusammenführen?
04.05.2006 18:38:14
Erich G.
Hallo Jochen(!),
deine Files haben mich doch etwas überrascht:
Das erste enthält überhaupt keine Daten, die Überschriften der Spalten A bis D fehlen.
Im zweiten File steht in A2 schon mal "Abteilung".
Aus welchem Grund auch immer ist Zeile 1 leer, in Zeile 2 kommen Überschriften, der Datenbereich beginnt in Zeile 3.
Ich habe das Makro jetzt so geändert, dass man die Überschriftzeile vorgeben kann. Außerdem wird nur bis zur letzten Zeile kopiert, die in der ersten zu kopierenden Spalte einen nichtleeren Wert enthält:
Option Explicit
Sub ZusammenfassenSp()
Dim wbkQ As Workbook, arr As Variant, iNrQ As Integer, iAnz As Integer
Dim datUhr As Date, iRowQ As Long, iRowZ As Long, iCol As Integer
Const strVerz = "c:\daten" ' Ordner/Verzeichnis mit den Quellmappen
Const boolInf = False 'True ' False, wenn Dateiname+Datum nicht in die Liste sollen
Const vBlatt = "Eingabe" ' Blattnummer oder Blattname in den Quellmappen
Const iColV = 1 ' 1. zu kopierende Spalte
Const iColB = 8 ' letzte zu kopierende Spalte
Const iRowU = 2 ' Zeile mit der Überschrift
Application.ScreenUpdating = False
Application.EnableEvents = False
' On Error GoTo ERRORHANDLER
arr = FileArray(strVerz, "*.xls")
For iNrQ = 1 To UBound(arr)
If arr(iNrQ) <> ThisWorkbook.Name Then
datUhr = Now
Application.StatusBar = "Öffne " & arr(iNrQ)
Set wbkQ = Workbooks.Open(strVerz & "\" & arr(iNrQ), 0, True)
With wbkQ.Worksheets(vBlatt)
iRowQ = Row_LastNotEmpty(.Columns(iColV))
If iRowQ > 1 Then
iAnz = iAnz + 1
ThisWorkbook.Activate
If iAnz = 1 Then
If IsEmpty(Cells(1, 1)) Then
Range(.Cells(iRowU, iColV), .Cells(iRowU, iColB)).Copy
Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Cells(1, 1).Select
ActiveWindow.FreezePanes = True
End If
If boolInf Then
iCol = iColV + iColB
Range(Cells(1, iCol), Cells(1, iCol + 1)) = Split("Quelldatei am")
End If
End If
If iRowQ > iRowU Then
iRowZ = Cells(Rows.Count, 1).End(xlUp).Row + 1
Range(.Cells(iRowU + 1, iColV), .Cells(iRowQ, iColB)).Copy
Cells(iRowZ, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Application.CutCopyMode = False
If boolInf Then
Range(Cells(iRowZ, iCol), Cells(iRowZ + iRowQ - iRowU - 1, iCol)) = wbkQ.Name
Range(Cells(iRowZ, iCol + 1), Cells(iRowZ + iRowQ - iRowU - 1, iCol + 1)) = datUhr
End If
End If
End If
End With
wbkQ.Close savechanges:=False
End If
Next iNrQ
If UBound(arr) > -1 Then
ActiveWindow.FreezePanes = False
Cells(2, 1).Select
ActiveWindow.FreezePanes = True
Rows(1).HorizontalAlignment = xlHAlignCenter
If boolInf Then Columns(iCol + 1).NumberFormat = "dd.mm.yyyy hh:mm:ss"
ActiveSheet.UsedRange.Columns.AutoFit
iRowZ = iRowZ + iRowQ - iRowU
Application.Goto Cells(IIf(iRowZ > 25, iRowZ - 25, 1), 1), True
Cells(iRowZ, 1).Select
End If
ERRORHANDLER:
Application.StatusBar = False
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Function FileArray(ByVal strPath As String, sPattern As String)
Dim arr(), iNr As Integer, tmp As String
With Application.FileSearch
.NewSearch
.LookIn = strPath
.SearchSubFolders = False
.Filename = sPattern
.MatchTextExactly = True
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
ReDim arr(1 To .FoundFiles.Count)
For iNr = 1 To .FoundFiles.Count
tmp = .FoundFiles(iNr)
arr(iNr) = Right(tmp, Len(tmp) - InStrRev(tmp, "\"))
Next iNr
Else
ReDim arr(-1 To -1)
MsgBox "Es wurden keine Dateien gefunden.", vbInformation
End If
End With
FileArray = arr
End Function
Public Function Row_LastNotEmpty&(ByVal wo As Range)
Row_LastNotEmpty = Row_LastFound(wo, "*")
End Function
Public Function Row_LastFound&(ByVal wo As Range, ByVal was$)
On Error Resume Next
Row_LastFound = wo.Find(was, wo.Cells(1), xlValues, xlWhole, , xlPrevious).Row
End Function
Ich hoffe, das funzt jetzt auch bei dir. Denn auch ich habe nicht unendlich viel Zeit, für deine Firma "ehrenamtlich und damit kostengünstig" Programme zu schreiben - und bis nach dem Wochenende werde ich weg sein.
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort