Tabelle kopieren und in andere Datei einfügen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Guten Morgen Sepp,
Du schreibst:
Warum nicht einfach alle Dateien im Ordner A durchlaufen, entsprechende Datei in B suchen
das ist genau was ich brauche, ich weiss aber nicht wie ich da hinbekommen soll. Die entsprechende Datei ist diejenige die genauso heißt wie die andere BIS auf die letzten beiden Stellen.
Ich hatte deshalb die Idee für die Zuordnung die Auflistung zu verwerden.
Also Quelldatei (der Pfad) steht in Zelle A1 und Zieldatei (der Pfad) steht daneben in A2.
Und nun sollte das Makro einfach die Tabelle1 aus der Quelldatei kopieren und in die Zieldatei hineinfügen. Es soll immer das gesamte Tabellenblatt kopiert werden, keine Bereiche.
Um Deinen Gedanken aufzugreifen:
Hier müsste man wohl die Strings (Dateinamen) in A und B vergleichen aber dabei die letzten beiden Stellen nicht in den Vergleich mit einbeziehen.
Ergebnis:
Auswertung_01_AB (aus Ordner A)
Auswertung_01_CD (aus Ordner B) werden beim Vergleichen zu:
Auswertung_01
Auswertung_01
Im nächsten Schritt müsste die Tabelle1 aus der einen Datei kopiert werden und in die andere eingefügt werden.
Die Entscheidung welche Datei die Quelldatei und welche die Zieldatei ist könnte man wohl über die Ordner lösen.
Also:
Ordner A enthält die Quelldateien, Ordner B enthält die Zieldateien.
Müssten die Dateien in den Ordnern dazu sortiert sein?
Ich hoffe das hilft ein bischen weiter.
tschau
VBAmateur

Hallo ?,
probiere mal den folgenden Code, die Dateien in den Ordnern müssen nicht sortiert sein.
Der Code ist ungetestet!

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub copySheets()
  Dim objWbSource As Workbook, objWbCompare As Workbook
  Dim strSourcePath As String, strComparePath As String, strFile As String
  Dim vntSource() As Variant, vntCompare() As Variant
  Dim lngIndex As Long, lngN As Long
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
  End With
  
  strSourcePath = "E:\Forum" 'Verzeichnis mit Dateien A
  strComparePath = "E:\Forum\Test" 'verzeichnis mit Dateien B
  
  If Right(strSourcePath, 1) <> "\" Then strSourcePath = strSourcePath & "\"
  If Right(strComparePath, 1) <> "\" Then strComparePath = strComparePath & "\"
  
  strFile = Dir(strSourcePath & "*.xls*", vbNormal)
  
  Do While strFile <> ""
    Redim Preserve vntSource(lngIndex)
    vntSource(lngIndex) = strFile
    lngIndex = lngIndex + 1
    strFile = Dir
  Loop
  
  lngIndex = 0
  
  strFile = Dir(strComparePath & "*.xls*", vbNormal)
  
  Do While strFile <> ""
    Redim Preserve vntCompare(lngIndex)
    vntCompare(lngIndex) = strFile
    lngIndex = lngIndex + 1
    strFile = Dir
  Loop
  
  For lngIndex = 0 To UBound(vntSource)
    For lngN = 0 To UBound(vntCompare)
      If Left(vntCompare(lngN), InStrRev(vntCompare(lngN), ".") - 3) = Left(vntSource(lngIndex), InStrRev(vntSource(lngIndex), ".") - 3) Then
        Set objWbSource = Workbooks.Open(strSourcePath & vntSource(lngIndex))
        Set objWbCompare = Workbooks.Open(strComparePath & vntCompare(lngN))
        objWbCompare.Sheets("Tabelle1").Copy After:=objWbSource.Sheets(1)
        objWbSource.Close True
        objWbCompare.Close False
        Exit For
      End If
    Next
  Next
  
  ErrExit:
  'Meldung bei Fehler
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "Modul1 - copySheets" & Space(35) & vbLf & vbLf & _
        IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
        "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbLf & _
        .Description, vbExclamation, "Fehler - Modul1 - copySheets"
    End If
    .Clear
  End With
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
  End With
  
  Set objWbSource = Nothing
  Set objWbCompare = Nothing
End Sub

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

Tabelle kopieren und in andere Datei einfügen

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

395 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Tabelle kopieren und in andere Datei einfügen

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

395 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread