Daten umkopieren

[johammer]

Moin zusammen,

ich habe mir zu Testzwecken zwei identische Dateien erstellt, (eben zum Lernen)
eine Mappe_Quelle und die Mappe_Ziel.
Jetzt möchte ich aus der Mappe_Quelle - Tab Jahresdaten01, die neuen Werte
in die Mappe_Ziel - Tab Übersicht reinkopieren
Das Makro soll die nächste leere Zeile finden und dort reinkopieren.
Sub Kopieren()
'
' Kopieren Makro
'
    ChDir "C:\Users\User\OneDrive"
    ActiveWorkbook.SaveAs Filename:= _
        "https://d.docs.live.net/bc46d210da970b57/Mappe_Quelle.xlsm", FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    Sheets("Jahresdaten01").Select
    Cells.Copy
    Workbooks.Open Filename:= _
        "https://d.docs.live.net/BC46D210DA970B57/Mappe_Ziel.xlsx"
    With ActiveSheet
        Dim lastRow As Long
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
    End With
    Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    Application.CutCopyMode = False

End Sub

Diesen Code hat der Copilot generiert, bekomme aber leider in der Codezeile Range einen Debuggen Fehler, auch nachdem er einmal umgeschrieben hat.
Wer kann mir da helfen?

Lg Jo

[Egon12]

Hallo Jo,

mal ein anderer Denkansatz als kopieren. Dies kann man bei gleichen Tabellenaufbau via Recordset ohne große Verrenkungen machen.

in ein allgemeines Modul der Zieldatei:

Code:

Option Explicit
    Private Const Rohdaten As String = "Übersicht"   ' Name des Tabelleblattes in dem der Datev Auszug sich befindet
    Private rs As ADODB.Recordset, arr(), Pfad$, ersterDatensatz
Sub DatenHolen()
    Dim arrQuelle(), i&, j&, lz&
    PfadFestlegen
    If Pfad = "" Then Exit Sub
    Set rs = New ADODB.Recordset
    With rs
        .Open "SELECT * FROM [" & Rohdaten & "$]", "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0 xml"";" & "Data Source= " & Pfad
        If Not (.EOF And .BOF) = True Then
            arrQuelle = rs.GetRows
            ReDim arr(1 To UBound(arrQuelle, 2) + 1, 1 To UBound(arrQuelle, 1) + 1)
            For i = 1 To UBound(arr, 1)
                For j = 1 To UBound(arr, 2)
                    If arrQuelle(j - 1, i - 1) <> "Null" Then arr(i, j) = arrQuelle(j - 1, i - 1)
                Next j
            Next i
            .MoveFirst
        End If
    End With
    Tabelle1.Cells(Tabelle1.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub
Sub PfadFestlegen()
    Dim objFdl As Variant
    Set objFdl = Application.FileDialog(msoFileDialogOpen)
    With objFdl
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        Pfad = .SelectedItems.Item(1)
    End With
End Sub

  Mappe_Ziel.xlsm (Größe: 19,84 KB / Downloads: 3)
Das Ganze ist Early Binding programmiert und dazu muss Micorsoft ActiveX Data Objects 6.1 Library aktiviert werden.
Wenn du den Pfad fix haben willst brauchst du nur einfach der Variable Pfad den korrekten Verzeichnis String zu verpassen und die Sub Pfadfestlegen nicht mehr aufrufen lassen.


Gruß Uwe

[snb]

Es reicht nur 2 VBA code Zeilen:

Code:

Sub M_snb()
  sn = Cells(1).CurrentRegion
  Workbooks.Open("G:\OF\voorbeeld.xlsb").Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(sn), UBound(sn, 2)) = sn
End Sub

[johammer]

Hallo einen Guten Morgen,

@Egon12
@Snb

vielen Dank an Euch für die schnelle Hilfe, bin Gestern nicht mehr dazu gekommen zum Testen.
Werde mich aber Heute ausgiebig damit befassen.

LG Jo