Zusammenführen von mehreren Exceldateien
02.02.2015 22:32:53
mehreren
ich stehe aktuell vor der Aufgabe mehrere Excel-Dateien (ca. 50 Stück) zu einer Datei zusammen zuführen und dort weitere Auswertungen zu machen. Ursprünglich hatte ich vor alle Dateien in "Rohform" zusammen zufassen und dann zu bearbeiten, das ist leider auf Grund der Größe der Enddatei (ca. 300.000 Zeilen) nicht praktisch möglich.
Ausführungsdauer sprengt den Rahmen.
Ich habe einen Code gefunden er sich zum selektieren gut eignet, also meiner Meinung nach:) Allerdings ist er nur für eine Datei programmiert.
Hier wird nach einem Zelleninhalt gesucht und dann die komplette Zeile ausgegeben.
Wie kann ich den Code ändern, damit alle Quelldateien (alle im selben Ordner) möglichst unkompliziert auswählen kann?
Aktueller Code bezieht auf die selbe Datei:
"Set WSq = Worksheets("Tabelle2")"
Ist es möglich, hier auch die Quelle der Ursprungsdatei anzugeben. Also:
Bsp.- "kopierte Zellen A1:J1" Zelle.AK "Verweis auf Quelldatei"
Ist das machbar?
unten habe ich den Code angeführt.
Schon jetzt, vielen , vielen Dank für eure Hilfe!
Lg
Michi
Sub Start()
Dim Suche As String
Suche = InputBox("Nach welchem Debitor soll gesucht werden?")
If Len(Suche) Then
MsgBox ("Es wurden " & AuswahlKopieren(Suche, True) & " Auftragsdaten selektiert!")
End If
End Sub
Function AuswahlKopieren(SuchStr As String, Optional Ganz As Boolean = False) As Integer
Dim WSq As Worksheet
Dim WSz As Worksheet
Dim SuchColRng As Range
Dim FRng As Range
Dim CRng As Range
Dim FirstAdr As String
Dim CArr As Variant
'comment: SET WSQ quelle - WSz Ziel
Set WSq = Worksheets("Tabelle2")
Set WSz = Worksheets("Tabelle1")
Set SuchColRng = WSq.Range("A:N")
With SuchColRng
If Ganz Then
Set FRng = .Find(SuchStr, LookIn:=xlValues, LookAt:=xlWhole)
Else
Set FRng = .Find(SuchStr, LookIn:=xlValues, LookAt:=xlPart)
End If
If Not FRng Is Nothing Then
FirstAdr = FRng.Address
Do
If CRng Is Nothing Then
Set CRng = WSq.Rows(FRng.Row)
Else
Set CRng = Union(WSq.Rows(FRng.Row), CRng)
End If
Set FRng = .FindNext(FRng)
Loop While Not FRng Is Nothing And FRng.Address FirstAdr
End If
End With
If Not CRng Is Nothing Then
CRng.Copy
WSz.Cells(WSz.Cells(WSz.Rows.Count, SuchColRng.Column).End(xlUp).Row + 1, 1). _
PasteSpecial xlPasteValues
Application.CutCopyMode = False
AuswahlKopieren = CRng.Cells.Count / 256
Else
AuswahlKopieren = 0
End If
End Function