Makro zum Importieren von Daten

Hallo Zusammen,
ich habe eine Frage bezüglich Datenimporten von einem Exceldokument in eine anderes.
Ich habe 4 fixen Pfad:
C:\Users\Robert\Documents1\
C:\Users\Robert\Documents2\
C:\Users\Robert\Documents3\
C:\Users\Robert\Documents4\
In diesem Pfad sind dann Ordner entsprechend der Kalenderwoche hinterlegt.
KW 40
KW 41
KW 42
In diesen Ordnern ist dann wiederum eine Datei die jede Woche neu erstellt und bearbeitet wird. Der Name lautet aber immer
Test
Somit ergeben sich folgende Pfade abhängig von der KW:
C:\Users\Robert\Documents1\KW40\Test
C:\Users\Robert\Documents2\KW40\Test
C:\Users\Robert\Documents3\KW40\Test
C:\Users\Robert\Documents4\KW40\Test
und in der nächsten Woche dann
C:\Users\Robert\Documents1\KW41\Test
C:\Users\Robert\Documents2\KW41\Test
C:\Users\Robert\Documents3\KW41\Test
C:\Users\Robert\Documents4\KW41\Test
Nun kopiere ich jeden morgen die Daten aus allen Dokumenten zusammen in eine Datei "Auswertung" Dabei werden die Daten aus "Tabelle 1 A:A" in die Tabelle import kopiert. Immer alle untereinander während die Daten aus "Tabelle 2 A2:B5" in Tabelle Import in jeweils fixe Fenster kopiert werden. Zum besseren Verständnis habe ich eine Beispieldatei hochgeladen.
https://www.herber.de/bbs/user/108517.xlsx
Meine Frage ist jetzt:
Kann das Öffnen und Kopier mittels Makro automatisiert werden und wenn ja, wie
müsste das Makro aussehen? Wie umgehe ich die Problematik das die Auswertungsdatei immer die gleiche bleibt während sich die Pfade für die Testdatei immer wieder ändern? Kann ich den Pfad in einer Zelle im Tabellenblatt hinterlegen und bei Bedarf ändern? Es kann auch vorkommen das ich in KW 45 die Auswertung von KW 40 nochmal machen möchte.
Danke schonmal für eure Hilfe
Gruß
Robert

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Makro zum Importieren von Daten

30.09.2016 09:18:32

Daten

AW: Makro zum Importieren von Daten

30.09.2016 10:26:22

Daten

AW: Makro zum Importieren von Daten

30.09.2016 13:42:21

Daten

offen

30.09.2016 14:02:31

UweD

mal sehen

01.10.2016 16:03:48

Michael

Frage

05.10.2016 07:40:14

Robert

AW: Frage

05.10.2016 08:45:00

UweD

AW: Frage

05.10.2016 11:21:39

Robert

AW: Frage

05.10.2016 12:52:20

Michael

AW: Frage

06.10.2016 05:56:42

Robert

AW: Frage

06.10.2016 13:31:52

Michael

Sub Importieren() On Error GoTo Fehler Dim WB1, WB2, ZielTB, TB1, TB2, ZielRNG As Range Dim Pfad As String, KW As Integer, Datei As String, Ext As String Dim LR As Long, LR2 As Long, i As Integer Set WB1 = ActiveWorkbook Set ZielTB = WB1.Sheets("Import") ' anpassen*** Set ZielRNG = ZielTB.Range("D5") ' der Zielbereich für A2:B5 bitte abändern Ext = ".xlsx" ' Ende anpassen*** Pfad = "C:\Users\Robert\Documents" KW = WorksheetFunction.WeekNum(Date, 11) KW = InputBox("Eingabe Kalenderwoche", "Verzeichnisauswahl", KW) For i = 1 To 4 Datei = Pfad & i & "\KW" & KW & "\Test" & Ext Workbooks.Open Filename:=Datei Set WB2 = ActiveWorkbook Set TB1 = WB2.Sheets("Tabelle1") Set TB2 = WB2.Sheets("Tabelle2") LR = ZielTB.Cells(ZielTB.Rows.Count, "A").End(xlUp).Row + 1 'erste Freie Zeile Spalte A LR2 = TB1.Cells(TB1.Rows.Count, "A").End(xlUp).Row 'letzte Zeile Spalte A TB1.Range(TB1.Cells(1, 1), TB1.Cells(LR2, 1)).Copy ZielTB.Cells(LR, 1) TB2.Range("A2:B5").Copy ZielRNG ' !!!wird immer wieder überschrieben WB2.Close savechanges:=False Next Err.Clear Fehler: If Err.Number <> 0 Then MsgBox "Fehler: " & _ Err.Number & vbLf & Err.Description: Err.Clear End Sub

Sub Importieren() On Error GoTo Fehler Dim WB1, WB2, ZielTB, TB1, TB2, ZielRNG As Range Dim Pfad As String, KW As Integer, Datei As String, Ext As String Dim LR As Long, LR2 As Long, i As Integer Set WB1 = ActiveWorkbook Set ZielTB = WB1.Sheets("Import") ' anpassen*** Set ZielRNG = ZielTB.Range("L3") ' *** geändert *** Ext = ".xlsx" ' Ende anpassen*** Pfad = "C:\Users\Robert\Documents" KW = WorksheetFunction.WeekNum(Date, 11) KW = InputBox("Eingabe Kalenderwoche", "Verzeichnisauswahl", KW) For i = 1 To 4 Datei = Pfad & i & "\KW" & KW & "\Test" & Ext Workbooks.Open Filename:=Datei Set WB2 = ActiveWorkbook Set TB1 = WB2.Sheets("Tabelle1") Set TB2 = WB2.Sheets("Tabelle2") LR = ZielTB.Cells(ZielTB.Rows.Count, "A").End(xlUp).Row + 1 'erste Freie Zeile Spalte A LR2 = TB1.Cells(TB1.Rows.Count, "A").End(xlUp).Row 'letzte Zeile Spalte A TB1.Range(TB1.Cells(1, 1), TB1.Cells(LR2, 1)).Copy ZielTB.Cells(LR, 1) TB1.Range(TB1.Cells(1, 6), TB1.Cells(LR2, 6)).Copy ZielTB.Cells(LR, 6) ' *** neu: F *** ' TB2.Range("A2:A6").Copy ZielRNG ' !!!wird immer wieder überschrieben TB2.Range("A2:A6").Copy ZielRNG ' *** von WOHER? *** ' so wird der Zielbereich von mal zu mal ' um 2 Spalten versetzt: Set ZielRNG = ZielRNG.Offset(, 2) ' *** geändert *** WB2.Close savechanges:=False Next Err.Clear Fehler: If Err.Number 0 Then MsgBox "Fehler: " & _ Err.Number & vbLf & Err.Description: Err.Clear End Sub

Guten Morgen,
ich habe es für mich jetzt so gelöst das ich jedes Dokument einzeln lade da der Dateipfad doch noch mehr variablen enthält. Somit habe ich 4 ähnlich aufgebaute Macros aus deiner Vorlage gemacht.

Private Sub CommandButton1_Click()
On Error GoTo Fehler
Dim WB1, WB2, ZielTB, TB1, TB2, ZielRNG As Range
Dim Pfad As String, KW As Integer, Datei As String, Ext As String
Dim LR As Long, LR2 As Long, i As Integer
Set WB1 = ActiveWorkbook
Set ZielTB = WB1.Sheets("Import")
' anpassen***
Set ZielRNG = ZielTB.Range("L3") ' *** geändert ***
Ext = ".xlsx" ' Ende anpassen***
Pfad = "D:\test\test1\test2\test3\Ordner 1&2"
KW = WorksheetFunction.WeekNum(Date, 11) - 1
KW = InputBox("Eingabe Kalenderwoche", "Verzeichnisauswahl", KW)
For i = 1 To 1
Datei = Pfad & "\KW " & KW & "\Prüfung"
Workbooks.Open Filename:=Datei
Set WB2 = ActiveWorkbook
Set TB1 = WB2.Sheets("Test")
Set TB2 = WB2.Sheets("Test")
LR = ZielTB.Cells(ZielTB.Rows.Count, "A").End(xlUp).Row + 1 'erste Freie Zeile Spalte A
LR2 = TB1.Cells(TB1.Rows.Count, "A").End(xlUp).Row 'letzte Zeile Spalte A
TB1.Range(TB1.Cells(2, 1), TB1.Cells(LR2, 1)).Copy ZielTB.Cells(LR, 1)
TB1.Range(TB1.Cells(2, 6), TB1.Cells(LR2, 6)).Copy ZielTB.Cells(LR, 6) ' *** neu: F ***
'TB2.Range("L2:L6").Copy ZielRNG ' !!!wird immer wieder überschrieben
TB2.Range("L2:L6").Copy ZielRNG  ' *** von WOHER? ***
' so wird der Zielbereich von mal zu mal
' um 2 Spalten versetzt:
Set ZielRNG = ZielRNG.Offset(, 2) ' *** geändert ***
WB2.Close savechanges:=False
Next
Err.Clear
Fehler:
If Err.Number  0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
End Sub

Bitte habt Verständnis dafür das ich den Pfad nicht im Original darstelle.
Wenn ich wie von dir vorgeschlagen
TB2.Range("A2:A6").Copy ZielRNG
gegen
ZielRNG.value = TB2.Range("L2:L6").value
ersetze wird nur noch die erste Zelle L2 eingefügt.
Bitte nicht lachen wenn es etwas schlampig aus sieht. Ich hab es nicht besser hin bekommen.
Gruß Robert

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

307 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Makro zum Importieren von Daten

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

307 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread