Copy & Paste Routine

Hallo Leute,
ein Newbie ist nach dem ersten gelösten Problem auf den Geschmack gekommen, weitere Makros zur Erledigung von Routine-Aufgaben zu konstruieren.
Ausgangslage:
Ich habe viele viele Excel-Dateien in einem Verzeichnis, die Daten enthalten. Die Inhalte dieser Einzeldateien (z.B. 1.xls, 2.xls, 3.xls, usw.) möchte ich der Reihe nach in ein bestehendes Worksheet, das aus vielen vielen Einzelsheets (Tabellen) aufgebaut ist, einlesen. Dabei ist jede Tabelle des Worksheets identisch aufgebaut. Wie auch die Einzeldateien identisch aufgebaut sind (natürlich nicht deren Inhalt).
Die Anzahl der Einzeldateien ist allerdings variabel, so dass ich zuvor den "Endpunkt" (=die letzte Datei) definieren müßte.
Bisher habe ich die Einzeldateien der Reihe nach geöffnet, die Inhalte markiert, in die Zwischenablage kopiert, in das Ziel-Worksheet gewechselt und dort die entsprechende Tabelle angeklickt und die Daten mit "einfügen" eingefügt. Das müßte sich doch über ein Makro automatisieren lassen. Oder? Nur habe ich keine Ahnung wie.....
Kan mir jemand weiterhelfen?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub DateienListen() Const Verz = "c:\test" Dim anz As Integer, i As Integer Dim fn As String fn = "*.xls" With Application.FileSearch .NewSearch .LookIn = Verz .FileType = msoFileTypeExcelWorkbooks .Filename = fn .SearchSubFolders = False .Execute anz = .FoundFiles.Count For i = 1 To .FoundFiles.Count fn = .FoundFiles(i) MsgBox fn 'hier müsste dann die Ausleseroutine rein Next i End With End Sub

Sub Import() Dim i As Integer Dim fn As String i = 1 Application.ScreenUpdating = False 'gegen das Flackern fn = ThisWorkbook.Path & "\" & i & ".xls" Do While Dir(fn) <> "" Workbooks.Open Filename:=fn ActiveWorkbook.Sheets("Tabelle1").Range("A1:E28").Copy ThisWorkbook.Sheets("Tabelle" & i).Range("A6").PasteSpecial _ Paste:=xlPasteValues 'nur Werte einfügen Application.DisplayAlerts = False 'Damit die Zwischenablage-Warnung nicht erscheint ActiveWorkbook.Close SaveChanges:=False Application.DisplayAlerts = True i = i + 1 fn = ThisWorkbook.Path & "\" & i & ".xls" Loop Application.ScreenUpdating = True End Sub

Sub Import_2terVersuch() Dim i As Integer Dim fn As String Dim Bl As String i = 1 Application.ScreenUpdating = False 'gegen das Flackern ' liest erste Datei mit dem angegebenen Muster fn = Dir(ThisWorkbook.Path & "\NO1***A.xls") ' Solange eine Datei gefunden wurde Do Until fn = "" ' Blattname aus Dateiname generieren Bl = Mid(fn, 4, 3) 'Debug.Print fn, Bl Workbooks.Open Filename:=ThisWorkbook.Path & "\" & fn ActiveWorkbook.Sheets("Tabelle1").Range("A1:E28").Copy ThisWorkbook.Sheets(Bl).Range("A6").PasteSpecial _ Paste:=xlPasteValuesAndNumberFormats 'nur Werte und Formate einfügen ThisWorkbook.Sheets(Bl).Range("A6").PasteSpecial _ Paste:=xlPasteColumnWidths 'und Spaltenbreiten Application.DisplayAlerts = False 'Damit die Zwischenablage-Warnung nicht erscheint 'Mappe schließen ohne zu speichern ActiveWorkbook.Close SaveChanges:=False Application.DisplayAlerts = True i = i + 1 'nächste Datei mit dem Muster holen fn = Dir() 'und Schleife Loop Application.ScreenUpdating = True End Sub

Hallo R.,
also, folgende Voraussetzungen:
- Das Makro steht in der Datei, in die die Bereiche kopiert werden sollen
- Diese Datei hat bereits Blätter mit den Namen 002, 004, 006, ...
- in gleichen Verzeichnis stehen Dateien mit den Namen NO1002A.xls, NO1004A.xls,NO1006A.xls,...
- Diese hateien haben Blätter entsprechend ihrem Namen, also NO1002A, NO1004A, NO1006A, ...

Sub Import()
Dim i  As Integer
Dim fn As String
Dim Bl As String, Bl_Source As String
i = 1
Application.ScreenUpdating = False 'gegen das Flackern
' liest erste Datei mit dem angegebenen Muster
fn = Dir(ThisWorkbook.Path & "\NO1***A.xls")
' Solange eine Datei gefunden wurde
Do Until fn = ""
' Blattnamen aus Dateiname generieren
Bl = Mid(fn, 4, 3)          ' aus 'NO1002A.xls' mach '002'
Bl_Source = Left(fn, Len(fn) - 4) ' aus 'NO1002A.xls' mach 'NO1002A'
'Debug.Print fn, Bl
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & fn
ActiveWorkbook.Sheets(Bl_Source).Range("A1:E28").Copy
ThisWorkbook.Sheets(Bl).Range("A6").PasteSpecial _
Paste:=xlPasteValues 'nur Werte einfügen
ThisWorkbook.Sheets(Bl).Range("A6").PasteSpecial _
Paste:=xlPasteColumnWidths 'Spaltenbreite wie Quelle
Application.DisplayAlerts = False 'Damit die Zwischenablage-Warnung nicht erscheint
'Mappe schließen ohne zu speichern
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
i = i + 1
'nächste Datei mit dem Muster holen
fn = Dir()
'und Schleife
Loop
Application.ScreenUpdating = True
End Sub

Gruß Matthias

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Copy & Paste Routine

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread