Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA: Arbeitsmappen öffnen und Felder kopieren

VBA: Arbeitsmappen öffnen und Felder kopieren
25.07.2017 09:01:07
FauBeA
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

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

Betreff
Datum
Anwender
Anzeige
AW: VBA: Arbeitsmappen öffnen und Felder kopieren
25.07.2017 09:57:10
Armin
Hallo
Dein Code kann überhaupt nicht laufen! Die Ext muss gleich "Mastermappe.xlsm" heißen.
Weiterhin wenn die Zellen "A3:BJ3" in die Zeile der Mastermappe geschrieben werden wo in Spalte "U" ein Filename steht wir dieser mit überschrieben "BJ". Ich hoffe das ist gewollt.
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
Gruß Armin
Anzeige
AW: VBA: Arbeitsmappen öffnen und Felder kopieren
25.07.2017 10:57:11
FauBeA
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 :)
Anzeige
AW: VBA: Arbeitsmappen öffnen und Felder kopieren
25.07.2017 09:58:50
UweD
Hallo
Vorab:
Select und Activate wird in 99% der Fälle nicht benötigt.
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

LG UweD
Anzeige
AW: VBA: Arbeitsmappen öffnen und Felder kopieren
25.07.2017 10:57:16
FauBeA
Hallo Uwe,
vielen Dank für deine Antwort. Habe dein Code ausprobiert und überarbeitet.
Workbooks.Open Filename:=sPath & sVal & cDir muss heißen:
Workbooks.Open Filename:=sPath & cDir
Dann wird die richtige Arbeitsmappe zwar geöffnet, aber der Inhalt von dem Arbeitsblatt Daten nicht in der Mastermappe ab Feld Y9 angezeigt. Es passiert gar nichts.
Und in deinem Code wird U9 fest angegeben. In jeder Zeile stehen die Namen für die Datenmappen. Das heißt, es muss nachgeschaut werden was in den jeweiligen Zeilen in der Spalte U drin steht, diese Datenmappe geöffnet und wiederum in die jeweilige Zeile ab Feld Y eingefügt werden. Z.B. wenn in Feld U15 eine Datenmappe eingetragen wurde, soll diese geöffnet, die Felder kopiert und in der Mastermappe wiederum ab Feld Y15 eingefügt werden.
Vielen Dank im Voraus für deine Hilfe :)
Anzeige
dann lad doch mal eine Musterdatei hoch
25.07.2017 11:04:24
UweD
AW: dann lad doch mal eine Musterdatei hoch
25.07.2017 11:46:05
Armin
Hallo
also wenn Du es richtig beschrieben hast müsste es jetzt gehen. Vorrausgesetzt in den Mappen die Du öffnen willst ist eine Tabelle mit dem Namen "Daten" vorhanden!!
Wenn nicht, musst Du das im Code Worksheets("Daten").Range("A1:BJ1").Copy anpassen.

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 
Gruß Armin
Anzeige
AW: dann lad doch mal eine Musterdatei hoch
25.07.2017 13:08:32
FauBeA
Vielen lieben Dank. Funktioniert nun perfekt.
Eine Bitte habe ich noch, manchmal steht die Datenmappe nicht in der Spalte U sondern V. Das heißt, wenn U leer ist und in V etwas drin steht, dann muss diese Mappe geöffnet werden. Und wenn in U und V etwas drin steht, dann gilt U als Datenmappe.
AW: dann lad doch mal eine Musterdatei hoch
25.07.2017 13:27:23
UweD
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
LG UweD
Anzeige
AW: dann lad doch mal eine Musterdatei hoch
25.07.2017 13:36:43
FauBeA
Funktioniert leider nicht. Die Zeile wird einfach übersprungen!?
Also ich bin raus
25.07.2017 13:43:12
UweD
..
- dein Beispieldatei(en) passen nicht zu deinen Beschreibungen
- Immer wieder was neues dazu
- ungenaue Fehlerbeschreibungen
= Funktioniert leider nicht. Die Zeile wird einfach übersprungen!?
Was meinst du mit Zeile? im Tabellenblatt, oder wird eine Zeile im Makro nicht abgearbeitet?
LG UweD
AW: Also ich bin raus
25.07.2017 13:49:33
FauBeA
Sorry. Bitte nicht schimpfen mit mir :)
Ich weiß ich mache es nicht unbedingt einfach für euch, bin halt noch ein Säugling in Sachen VBA.
Es zeigt sehr gut, was für Experten ihr seid, wenn ihr sogar meine schlechten Beispiele versteht.
Bin wirklich extrem dankbar dir und dem Armin auch.
Also ich versuchs besser zu erklären. Habe jetzt beispielsweise mal das Feld U4 leer gelassen und in V4 die Datenmappe eingetragen. Nach deinem Code sollte ja jetzt die Datenmappe aus V4 geöffnet werden. Das tut es aber leider nicht. Das Makro überspringt die Zeile 4 und betrachtet es als leer.!?
Anzeige
Letzter Versuch..
25.07.2017 14:15:11
UweD
- Also Zeilenweise abarbeiten
- wenn in U nichts ist, dann in der gleichen Zeile in V nachlesen..
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

LG UweD
Anzeige
AW: Letzter Versuch..
25.07.2017 16:42:10
FauBeA
PERFEKT.
Vielen vielen vielen lieben Dank. Auch für Euer Geduld :)
Funktioniert super.
:)
Prima. Danke für die Rückmeldung
25.07.2017 17:30:58
Der
Noch eine Frage :)
26.07.2017 15:05:24
FauBeA
Und jetzt bin ich es doch wieder. :) SOORRRYYY
Wie krieg ich es denn hin, nicht angrenzende Zeilen einzufügen.
Bisher wollte ich alles von A3:BJ3 angrenzend einfügen.
Es gibt nun aber in der Mastermappe Bereiche die nicht überschrieben werden dürfen, also darf ich die kopierten Zellen nicht angrenzend einfügen.
Kopiert werden die Zellen "A3,D3:M3,O3:T3,W3,Y3,AA3,AC3:AD3,AJ3,AL3:AM3,AQ3:AX3,BB3:BI3" von der Datenmappe und sollen eingefügt werden in die Mastermappe "Y3,AB3:AK3,AM3:AR3,AU3,AW3,AY3,BA3:BB3,BH3,BJ3:BK3,BO3:BV3,BZ3:CG3"
Gibt es hierfür auch eine Lösung in VBA?
Vielen Dank nochmals :)
Anzeige
AW: Noch eine Frage :)
26.07.2017 17:03:00
Armin
Hallo,
wenn es diesesmal die richtige Beschreibung war sollte es funktionieren.

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
Gruß Armin
AW: Noch eine Frage :)
27.07.2017 10:26:48
FauBeA
Dein Code funktioniert Super! Vielen Dank. :)
Wenn man das aber beobachtet wie es hin und her springt, wird man ja verrückt. :)
Wenn es dafür eine Augenschonversion gibt, würde ich diese nehmen, wenn nicht, ist das schon genug und erfüllt meine Anforderungen.
Ein Riesendank nochmals. :)
Antwort
27.07.2017 13:47:31
Armin
Hallo,
so müsste es besser sein.
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
Gruß Armin
AW: Antwort
27.07.2017 14:11:53
FauBeA
PERFEKT!!! Vielen Dank
Ich verstehe eigentlich jeden Schritt in deinem Code, außer Array die Funktion, was macht diese genau und For M = 0 To 10 und dann Urs(M) und Ma(M), für was steht M?
AW: Noch eine Frage :)
27.07.2017 15:55:11
Armin
Hallo siehe Kommentare.
' 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"
Gruß Armin
AW: Letzter Versuch..
25.07.2017 16:47:38
Armin
Hallo,
so ganz kann ich Dein Vorhaben nicht verstehen. Wieso kann in V der File-Name stehen wenn Du ab da sonst die Daten schreibst? Warum fängst Du denn nicht gleich erst bei W an? Was lehrt uns das, zunächst erst mal Geganken machen was will ich und wie soll es gut lesbar aus sehen. Dann Anfangen.
Bei Dir beginnen je nach dem wo jemand den Filenamen hinschreibt, die Spalte gff. versetzt. Das erhöht natürlich die Übersicht - ha ha.
Hier nun Dein gewünschter Code:
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
Gruß Armin
AW: dann lad doch mal eine Musterdatei hoch
25.07.2017 13:28:01
Armin
Hallo,
wo beginnt denn dann das einkopieren? in V? oder W oder was?
Excel wills genau wissen und VBA erst recht!
Gruß Armin
AW: VBA: Arbeitsmappen öffnen und Felder kopieren
25.07.2017 11:34:38
UweD
Hallo nochmal
ohne die Mustermappe zu kennen...
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

LG UweD

311 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige