VBA: Arbeitsmappen öffnen und Felder kopieren

Hallo liebes Forum,
ich bin ganz neu hier und auch in Sachen VBA kein Experte wie die meisten unter euch. :)
Ich habe folgende Anforderung, die ich in Excel VBA lösen möchte.
In einer Masterarbeitsmappe werden von anderen Arbeitsmappen Daten übernommen. Diese Arbeitsmappen sind jeweils immer in dem selben Verzeichnis im Unterordner "Daten" abgelegt.
Es werden immer die Felder von diesen Untermappen kopiert und in die Mastermappe eingefügt.
In der Mastermappe gibt es pro Zeile in der Spalte U den Namen für die Untermappe, aus der die bestimmten Felder in diese Zeile kopiert werden müssen.
z.B. steht in der Mastermappe in Zelle "U9": DatenMappe123
Jetzt muss anhand des Wertes in "U9" die DatenMappe123 im Unterordner "Daten" geöffnet werden und die Felder "A3:BJ3" kopiert und in das Feld "Y9" in der Mastermappe eingefügt werden.
Und das ganze muss für jede Zeile wiederholt werden, wo in der Spalte "U" ein Eintrag vorhanden ist.
Wie ich die Arbeitsmappe öffne und die Felder kpiere und einfüge habe ich schon gelöst. Nur nicht, wie ich in der nächsten Zeile (loop) weitermache.
Ihr könnt mir doch bestimmt helfen, oder?
Vielen Dank im Voraus :)
Hier mein Script:

Sub Makro1()
sPath = ActiveWorkbook.Path & "\Daten\"
sVal = Range("U9").Value
cDir = Dir(sPath & sVal & ".xlsx")
Workbooks.Open (sPath & cDir)
Sheets("Daten").Select
Range("A3:BJ3").Select
Selection.Copy
Windows("Mastermappe.xlsx").Activate
Range("Y9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Makro1() Dim SPath As String Dim sVal As String Dim xCount As Long Dim cDir As String SPath = ActiveWorkbook.Path & "\Daten\" For xCount = 1 To Tabelle1.Cells(Rows.Count, 21).End(xlUp).Row If Tabelle1.Cells(xCount, 21).Value "" Then sVal = Tabelle1.Cells(xCount, 21).Value cDir = Dir(SPath & sVal & ".xlsx") If cDir "" Then Workbooks.Open (SPath & cDir) Worksheets("Daten").Range("A3:BJ3").Copy Tabelle1.Range("A1").PasteSpecial xlPasteAll Workbooks(cDir).Close savechanges:=False End If End If Next End Sub

Hallo Armin,
danke für deine Antwort. Das stimmt so, ich habe den Code euch geschickt, noch bevor ich es gespeichert hatte als xlsm. Habe es danach angepasst.
Die Felder A3:BJ3 werden von der DatenMappe kopiert und ab der Spalte Y in die Mastermappe eingefügt. Somit wird die Spalte U nicht überschrieben. Danke trotzdem für den Hinweis.
Habe dein Code eingefügt, aber es funktioniert noch nicht so ganz.
Die richtige Datei wird geöffnet, aber aus dem falschen Arbeitsblatt die Felder kopiert.
Und mit Tabelle1.Range("Y1") wäre es ja so, dass in jeder Zeile zwar eine andere Mappe geöffnet wird, jedoch die Daten immer in Y1 reingeschrieben werden. Es sollte aber jeweils in die Zeile geschrieben werden, wo in der Spalte U die Arbeitsmappe für die Daten drin steht. Das heißt, in U3 werden die Felder ab Y3 eingefügt und wenn in Feld U4 eine Datenmappe eingetragen ist dann wird diese Mappe geöffnet und der Inhalt wiederum in der Mastermappe ab Y4 eingefügt.
Danke im Voraus für deine Hilfe :)

Sub alle_Dateien_Verzeichnis2() ' On Error GoTo Fehler Dim WB As Workbook, TB As Worksheet Dim sPath$, Ext$, cDir$, sVal$ Set WB = ActiveWorkbook Set TB = WB.Sheets("Tabelle1") sPath = WB.Path & "\Daten\" sVal = TB.Range("U9").Value Ext = "*.xlsx" cDir = Dir(sPath & sVal & Ext) Do While Len(cDir) > 0 Workbooks.Open Filename:=sPath & sVal & cDir TB.Range("Y9").Resize(1, 62) = _ ActiveWorkbook.Sheets("Daten").Range("A3").Resize(1, 62) Workbooks(cDir).Close False cDir = Dir() ' nächste Datei Loop Err.Clear Fehler: If Err.Number <> 0 Then MsgBox "Fehler: " & _ Err.Number & vbLf & Err.Description: Err.Clear End Sub

Sub Makro1() Dim SPath As String Dim sVal As String Dim xCount As Long Dim cDir As String SPath = ActiveWorkbook.Path & "\Daten\" For xCount = 1 To Tabelle1.Cells(Rows.Count, 21).End(xlUp).Row If Tabelle1.Cells(xCount, 21).Value "" Then sVal = Tabelle1.Cells(xCount, 21).Value cDir = Dir(SPath & sVal & ".xlsx") If cDir "" Then Workbooks.Open (SPath & cDir) Worksheets("Daten").Range("A1:BJ1").Copy Tabelle1.Cells(xCount, 22).PasteSpecial xlPasteAll Workbooks(cDir).Close savechanges:=False End If End If Next End Sub

Sub Makro1() Dim SPath As String Dim sVal As String Dim xCount As Long Dim cDir As String Dim iSp As Integer SPath = ActiveWorkbook.Path & "\Daten\" iSp = 21 ' U If WorksheetFunction.CountA(Columns(iSp)) = 0 Then iSp = iSp + 1 'V For xCount = 1 To Tabelle1.Cells(Rows.Count, iSp).End(xlUp).Row If Tabelle1.Cells(xCount, iSp).Value <> "" Then sVal = Tabelle1.Cells(xCount, iSp).Value cDir = Dir(SPath & sVal & ".xlsx") If cDir <> "" Then Workbooks.Open (SPath & cDir) Worksheets("Daten").Range("A1:BJ1").Copy Tabelle1.Cells(xCount, 25).PasteSpecial xlPasteAll ' Y Workbooks(cDir).Close False End If End If Next End Sub

Sub Makro1() Dim SPath As String Dim sVal As String Dim xCount As Long Dim cDir As String Dim iSp As Integer Dim LR As Long, LRU As Long, LRV As Long SPath = ActiveWorkbook.Path & "\Daten\" iSp = 21 'Spalte U LRU = Cells(Rows.Count, iSp).End(xlUp).Row LRV = Cells(Rows.Count, iSp + 1).End(xlUp).Row LR = WorksheetFunction.Max(LRU, LRV) For xCount = 1 To LR If Tabelle1.Cells(xCount, iSp).Value = "" And _ Tabelle1.Cells(xCount, iSp + 1).Value = "" Then 'mache nichts Else If Tabelle1.Cells(xCount, iSp).Value <> "" Then sVal = Tabelle1.Cells(xCount, iSp).Value Else sVal = Tabelle1.Cells(xCount, iSp + 1).Value End If cDir = Dir(SPath & sVal & ".xlsx") If cDir <> "" Then Workbooks.Open (SPath & cDir) Worksheets("Daten").Range("A1:BJ1").Copy Tabelle1.Cells(xCount, 25).PasteSpecial xlPasteAll ' Y Workbooks(cDir).Close False End If End If Next End Sub

Sub Makro1() Dim SPath As String Dim sVal As String Dim xCount As Long Dim cDir As String Dim N As Long, M As Long Dim Urs As Variant Dim Ma As Variant Urs = Array("A1", "D1:M1", "O1:T1", "W1", "Y1", "AA1", "AC1:AD1", "AJ1", "AL1:AM1", "AQ1:AX1", " _ BB1:BI1") Ma = Array("Y", "AB", "AM", "AU", "AW", "AY", "BA", "BH", "BJ", "BO", "BZ") SPath = ActiveWorkbook.Path & "\Daten\" If Tabelle1.Cells(Rows.Count, 21).End(xlUp).Row > Tabelle1.Cells(Rows.Count, 22).End(xlUp).Row _ Then N = Tabelle1.Cells(Rows.Count, 21).End(xlUp).Row Else N = Tabelle1.Cells(Rows.Count, 22).End(xlUp).Row End If For xCount = 1 To N If Tabelle1.Cells(xCount, 21).Value "" Then sVal = Tabelle1.Cells(xCount, 21).Value ElseIf Tabelle1.Cells(xCount, 22).Value "" Then sVal = Tabelle1.Cells(xCount, 22).Value End If cDir = Dir(SPath & sVal & ".xlsx") If cDir "" Then Workbooks.Open (SPath & cDir) For M = 0 To 10 Worksheets("Daten").Range(Urs(M)).Copy Tabelle1.Cells(xCount, Ma(M)).PasteSpecial xlPasteAll Next Workbooks(cDir).Close savechanges:=False End If Next End Sub

Sub Makro1() Dim SPath As String Dim sVal As String Dim xCount As Long Dim cDir As String Dim N As Long, M As Long Dim Urs As Variant Dim Ma As Variant Urs = Array("A1", "D1:M1", "O1:T1", "W1", "Y1", "AA1", "AC1:AD1", "AJ1", "AL1:AM1", "AQ1:AX1", " _ BB1:BI1") Ma = Array("Y", "AB", "AM", "AU", "AW", "AY", "BA", "BH", "BJ", "BO", "BZ") Application.DisplayAlerts = False Application.ScreenUpdating = False SPath = ActiveWorkbook.Path & "\Daten\" If Tabelle1.Cells(Rows.Count, 21).End(xlUp).Row > Tabelle1.Cells(Rows.Count, 22).End(xlUp).Row _ Then N = Tabelle1.Cells(Rows.Count, 21).End(xlUp).Row Else N = Tabelle1.Cells(Rows.Count, 22).End(xlUp).Row End If For xCount = 1 To N If Tabelle1.Cells(xCount, 21).Value "" Then sVal = Tabelle1.Cells(xCount, 21).Value ElseIf Tabelle1.Cells(xCount, 22).Value "" Then sVal = Tabelle1.Cells(xCount, 22).Value End If cDir = Dir(SPath & sVal & ".xlsx") If cDir "" Then Workbooks.Open (SPath & cDir) For M = 0 To 10 Worksheets("Daten").Range(Urs(M)).Copy Tabelle1.Cells(xCount, Ma(M)).PasteSpecial xlPasteAll Next Workbooks(cDir).Close savechanges:=False End If Next Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

' Das Array listet die Zellen auf die kopiert werden sollen Urs = Array("A1", "D1:M1", "O1:T1", "W1", "Y1", "AA1", "AC1:AD1", "AJ1", "AL1:AM1", "AQ1:AX1", " _ BB1:BI1") ' Das Array listet die Zellen auf wohin kopiert werden soll Ma = Array("Y", "AB", "AM", "AU", "AW", "AY", "BA", "BH", "BJ", "BO", "BZ") ' die Syntax -Array erlaubt zum Beispiel die Zell-information per Laufanweisung (For Next) _ abzurufen ' Das heißt zum Beipiel Urs(1) ="D1:M1" oder bei N=2 und Urs(N)="O1:T1"

Sub Makro1() Dim SPath As String Dim sVal As String Dim xCount As Long Dim cDir As String Dim N As Integer SPath = ActiveWorkbook.Path & "\Daten\" For xCount = 1 To Tabelle1.Cells(Rows.Count, 21).End(xlUp).Row If Tabelle1.Cells(xCount, 21).Value "" Then sVal = Tabelle1.Cells(xCount, 21).Value N = 0 ElseIf Tabelle1.Cells(xCount, 22).Value "" Then sVal = Tabelle1.Cells(xCount, 22).Value N = 1 End If cDir = Dir(SPath & sVal & ".xlsx") If cDir "" Then Workbooks.Open (SPath & cDir) Worksheets("Daten").Range("A1:BJ1").Copy Tabelle1.Cells(xCount, 22 + N).PasteSpecial xlPasteAll Workbooks(cDir).Close savechanges:=False End If Next End Sub

Sub Makro1() Dim WB As Workbook, Tb As Worksheet Dim Z, sPath As String, sVal, cDir As String Set WB = ActiveWorkbook Set Tb = WB.ActiveSheet sPath = WB.Path & "\Daten\" For Each sVal In Tb.Columns("U").SpecialCells(xlCellTypeConstants, 2) 'alle Zellen in U mit Text cDir = Dir(sPath & sVal & ".xlsx") If cDir <> "" Then Workbooks.Open (sPath & cDir) Tb.Range("Y" & sVal.Row).Resize(1, 62) = _ ActiveWorkbook.Sheets("Daten").Range("A3:BJ3").Value Workbooks(cDir).Close False Else MsgBox "'" & sPath & sVal & ".xlsx" & "' ist nicht vorhanden", vbCritical End If Next End Sub

Beliebteste Forumthreads (12 Monate)

VBA: Arbeitsmappen öffnen und Felder kopieren

24
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

311 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA: Arbeitsmappen öffnen und Felder kopieren

24 Beiträge zum Forumthread Beiträge zu diesem Forumthread

311 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

24
Beiträge zum Forumthread

Beiträge zu diesem Forumthread