Werte einer Mappe in viele andere Mappen kopieren

Hallo Zusammen,
ich bin mir nicht einmal sicher ob das mit Vba zu bewältigen ist, habe schon viel gegooglet aber nichts gefunden wo nur annährend passen könnte. Wenn jemand eine Idee hätte wäre ich euch sehr dankbar.
Ich habe eine Mappe (Mappe 1) und in einem anderen Verzeichnis noch ca. 150 weiter Mappen. In Mappe 1 stehen in Spalte A alle 150 Dateinamen aus dem Verzeichnis. In Spalte B das aktuelle Datum und in den folgenden Spalten (c bis ab) Werte welche täglich aktualisiert werden.
Das Makro soll nun die erste Excelmappe öffnen, deren Name in Spalte A steht. Anschließend soll das Makro abgleichen ob das Datum aus Mappe 1 schon inder neu geöffneten Mappe in Spalte A vorhanden ist, wenn ja dann soll es die Werte der Zellen von c bis ab aus der Zeile in welcher der Arbeitsmappenname steht kopieren und in die Zeile in der das Datum steht einfügen.
Wenn das Datum inder neu geöffneten Mappe noch nicht vorhanden ist dann soll es die Zellen b bis ab in die letzte leere Zeile kopieren.
Alternativ könnte man vielleicht auch alle Mappen aus dem Verzeichnis nacheinander öffnen und den Arbeitsmappenname in der Spalte A (Mappe 1) suchen und dann die Werte kopieren.
Ich hoffe ich habe mich einigermaßen verständlich ausgedrückt!
Im Voraus schon recht herzlichen Dank für eure Mühe.
Gruß Markus

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

' ********************************************************************** ' Modul: Modul3 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub MappenAktualisieren() Dim objWB As Workbook Dim strFile As String, strPath As String Dim vntRet As Variant Dim lngFirstRow As Long, lngLastRow As Long, lngRow As Long On Error GoTo ErrExit With Application .ScreenUpdating = False .EnableEvents = False End With strPath = "E:\Forum" 'Verzeichnis - Anpassen! strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\") lngFirstRow = 2 'Erste Datenzeile - Anpassen! With Sheets("Tabellename") 'Tabellenname - Anpassen! lngLastRow = Application.Max(lngFirstRow, .Cells(.Rows.Count, 1).End(xlUp).Row) For lngRow = lngFirstRow To lngLastRow If Dir(strPath & .Cells(lngRow, 1).Text, vbNormal) <> "" Then Set objWB = Workbooks.Open(strPath & .Cells(lngRow, 1).Text) vntRet = Application.Match(.Cells(lngRow, 2), objWB.Sheets(1).Columns(1), 0) If IsNumeric(vntRet) Then objWB.Sheets(1).Cells(vntRet, 2).Resize(1, 26) = _ .Range(.Cells(lngRow, 3), .Cells(lngRow, 28)).Value Else vntRet = objWB.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1 objWB.Sheets(1).Cells(vntRet, 1).Resize(1, 27) = _ .Range(.Cells(lngRow, 2), .Cells(lngRow, 28)).Value End If objWB.Close True End If Next End With ErrExit: If Err.Number <> 0 Then MsgBox "Fehler:" & vbTab & Err.Number & vbLf & vbLf & _ Err.Description, vbExclamation, "Fehler" End If With Application .ScreenUpdating = True .EnableEvents = True End With Set objWB = Nothing End Sub

Hallo Markus,
hier der Code mit Kommentaren.

Sub MappenAktualisieren()
  Dim objWB As Workbook
  Dim strFile As String, strPath As String
  Dim vntRet As Variant
  Dim lngFirstRow As Long, lngLastRow As Long, lngRow As Long
  
  On Error GoTo ErrExit 'Fehlerbehandlung
  With Application
    .ScreenUpdating = False 'Bildschirmaktualiesierung ausschalten
    .EnableEvents = False   'Ereignisüberwachung ausschalten
  End With
  strPath = "E:\Forum" 'Verzeichnis - Anpassen!
  strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
  lngFirstRow = 2 'Erste Datenzeile - Anpassen!
  With Sheets("Tabellename") 'Tabellenname - Anpassen!
    lngLastRow = Application.Max(lngFirstRow, .Cells(.Rows.Count, 1).End(xlUp).Row) 'letzte Datenzeile ermitteln
    
    For lngRow = lngFirstRow To lngLastRow
      If Dir(strPath & .Cells(lngRow, 1).Text, vbNormal) <> "" Then 'Prüfen ob Datei existiert
        Set objWB = Workbooks.Open(strPath & .Cells(lngRow, 1).Text)  'Datei öffnen
        vntRet = Application.Match(.Cells(lngRow, 2), objWB.Sheets(1).Columns(1), 0)  'Datum suchen
        If IsNumeric(vntRet) Then 'Wenn Datum gefunden
          objWB.Sheets(1).Cells(vntRet, 2).Resize(1, 26) = _
            .Range(.Cells(lngRow, 3), .Cells(lngRow, 28)).Value 'Werte einfügen
        Else  'Wenn datum NICHT gefunden
          vntRet = objWB.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1 'Nächste freie Zeile ermitteln
          
          objWB.Sheets(1).Cells(vntRet, 1).Resize(1, 27) = _
            .Range(.Cells(lngRow, 2), .Cells(lngRow, 28)).Value 'Daten einfügen
        End If
        objWB.Close True  'Datei speichern und schliessen
      End If
    Next
  End With
  ErrExit:
  If Err.Number <> 0 Then 'Fehlermeldung ausgeben
    MsgBox "Fehler:" & vbTab & Err.Number & vbLf & vbLf & _
      Err.Description, vbExclamation, "Fehler"
  End If
  With Application
    .ScreenUpdating = True  'Bildschirmaktualisierung einschalten
    .EnableEvents = True    'Ereignisüberwachung einschalten
  End With
  Set objWB = Nothing
End Sub

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

Werte einer Mappe in viele andere Mappen kopieren

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Werte einer Mappe in viele andere Mappen kopieren

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread