Ich habe mehrere Arbeitsmappen in einem Verzeichnis und möchte die Ergebnisse jeder Arbeitsmappe, welches immer in den Zellen A2 und A3
steht, in einer Übersicht zusammenführen.
Hierzu habe ich folgendes Makro gefunden, welches jede Datei öffnet und die Werte aus A2:A3 in das aktuelle Dokument in die Zelle A1 schreibt und danach 2 Zeilen weiter unten springt.
Jetzt möchte ich aber, dass die aus A2:A3 ausgelesen Daten an eine bestimmte Stelle geschrieben werden: das Makro soll sich aus der Spalte B die Kundennummer (z.B. 12345) merken, die entsprechende Kundendatei öffnen (Rechnung_12345_20040201.xls), dort die Zellen A2:A3 auslesen und in die Zeile mit der Kundenummer in der Übersicht springen und dort Stelle die übernommen Daten schreiben.
Hat jemand eine Idee, wie man das am besten hinbekommt?
Sub DateienZusammenKopieren()
Dim Mappe As String
Dim i As Integer
Mappe = ActiveWorkbook.name
Range(„A1“).Select
With Application.FileSearch
.NewSearch
.LookIn = „C:\temp“
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
.Execute
For i = 1 To .FoundFiles.Count
Workbooks.Open .FoundFiles(i)
Range(„A2:A3“).Copy
Workbooks(Mappe).Activate
ActiveSheet.Paste
ActiveCell.Offset(2, 0).Select
Next i
End With
End Sub
Hier ist mal was:
Function Aufnullen(Zahl As String, Optional Nullen As Integer) As String
Dim i As Integer
If Nullen = 0 Then Nullen = 1
For i = 1 To Nullen
Zahl = "0" & Zahl
Next i
Aufnullen = Zahl
End Function 'Aufnullen
Sub ZellenAusAnderenDateienAuslesen()
Dim Zelle As Range
Dim Pfad As String
Dim Muster1 As String
Dim Muster2 As String
Dim Dateiname As String
Dim Datum As String
Dim p As Integer
Dim S As Range
Dim WB As Workbook
Const Tabelle As String = "Tabelle1"
Const Zelle1 As String = "A2"
Const Zelle2 As String = "A3"
Const Variante As Integer = 1 'Bezug-Variante
'Const Variante As Integer = 2 'Öffnen-Kopier-Variante
'--------------------
Muster1 = "" 'wenn leer, wird´s abgefragt
Pfad = "" 'wenn leer, wird´s abgefragt
Datum = Year(Date) & Aufnullen(Month(Date)) & Aufnullen(Day(Date))
'--------------------
If Muster1 = "" Then
Muster1 = InputBox("Bitte das Datei-Muster angeben. " & \_
"Es muss genau ein Sternchen enthalten, das dann durch den jeweiligen Zellinhalt ersetzt wird:", \_
"Daten zusammenkratzen", \_
"Rechnung\_\*\_" & Datum & ".xls")
End If 'Muster1=""
p = InStr(1, Muster1, "\*")
If p = 0 Then
MsgBox "Das Datei-Muster enthält kein Sternchen." & vbCrLf & "Abbruch", vbCritical, "Fehler"
Exit Sub
Else
Muster2 = Mid(Muster1, p + 1)
Muster1 = Left(Muster1, p - 1)
End If 'p=0
'--------------------
If Pfad = "" Then
Pfad = InputBox("Bitte den Pfad zu den Dateien angeben" & vbCrLf & \_
"(absolut oder relativ):", \_
"Daten zusammenkratzen", \_
ActiveWorkbook.Path)
End If 'Pfad=""
If Right(Pfad, 1) "\" Then Pfad = Pfad & "\"
'--------------------
Set S = Selection
For Each Zelle In S
If Zelle.Value "" Then
Dateiname = Muster1 & Zelle.Value & Muster2
If Dir(Pfad & Dateiname) = "" Then
Zelle.Offset(0, 1).Value = """" & Dateiname & """konnte nicht gefunden werden! - " & Pfad
Else
Select Case Variante
Case 1
'Variante 1: Bezug auf andere Datei
'==================================
With Zelle.Offset(0, 1)
.Formula = "='" & Pfad & "[" & Dateiname & "]" & Tabelle & "'!" & Zelle1
.Copy
.PasteSpecial xlPasteValues 'Bezug löschen und durch reinen Wert ersetzen
End With
With Zelle.Offset(0, 2)
.Formula = "='" & Pfad & "[" & Dateiname & "]" & Tabelle & "'!" & Zelle2
.Copy
.PasteSpecial xlPasteValues 'Bezug löschen und durch reinen Wert ersetzen
End With
Case 2
'Variante 2: Öffnen der anderen Datei und kopieren der Werte
'===========================================================
Set WB = Workbooks.Open(Pfad & Dateiname, 0, True, , , , True)
WB.Worksheets(1).Range(Zelle1).Copy
Zelle.Offset(0, 1).PasteSpecial 'fügt formatiert ein
'Zelle.Offset(0, 1).PasteSpecial xlPasteValues 'fügt nur den Wert ein
WB.Worksheets(1).Range(Zelle2).Copy
Zelle.Offset(0, 2).PasteSpecial 'xlPasteValues
'mit "xlPasteValues" wird nur der Wert eingefügt, sonst komplett formatiert
WB.Close
Set WB = Nothing
End Select 'Variante
'Bei "Offset(0, x)" werden die Werte in die gleiche Zeile nebeneinander geschrieben.
'Bei "Offset(x, 0)" werden die Werte in die gleiche Spalte untereinander geschrieben.
End If 'Dir(DateiPfad)=""
End If 'Zelle.Value""
Next Zelle
S.Select
Set S = Nothing
End Sub 'ZellenAusAnderenDateienAuslesen
Ich gehe dabei davon aus, dass in der Tabelle, in der das Makro läuft, ein paar Rechungsnummern stehen (z.B. in A1, A2, A3, A4, …). Diese müssen markiert werden, bevor das Makro gestartet wird. Die Quell-Zellen „A1“ und „A2“ sind im Makro festgelegt („Const …“).
Kristian