Übetragung von Datensätzen bei 2 Dateien
20.12.2020 22:42:49
Datensätzen
ich habe damals folgenden Code bekommen:
Dim Wq As Worksheet 'Quelle
Dim Wz As Worksheet 'Ziel
Sub Uebertrage()
Dim Z
Set Wq = Workbooks("Liste_2").Worksheets("Tabelle1")
Set Wz = Workbooks("Liste_2").Worksheets("Tabelle2")
Sortieren Wq, "A1:C1000", "C1", xlAscending
Sortieren Wz, "F1:H1000", "H1", xlDescending
For Each Z In Wq.Range(Wq.Range("C1"), Wq.Range("C10000").End(xlUp)).Cells
If Z >= Wz.Range("H1") Then Exit For
Next
If Z Wq.Range(Z.Offset(0, -2), Wq.Range("C10000").End(xlUp)).Copy
Wz.Activate
Wz.Range("F10000").End(xlUp).Offset(1, 0).Select
Wz.Paste
Application.CutCopyMode = False
Sortieren Wz, "F1:H200", "H1", xlDescending
End Sub
Private Sub Sortieren(W As Worksheet, SortBereich As String, SortZelle As String, Richtung As _
XlSortOrder)
With W.Sort
.SortFields.Clear
.SortFields.Add _
Key:=Intersect(W.Range(SortBereich), W.Range(SortZelle).EntireColumn), _
SortOn:=xlSortOnValues, Order:=Richtung, DataOption:=xlSortNormal
.SetRange W.Range(SortBereich)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Dieser Code überträgt die aktuellen Datensätze von einem Tabellenblatt, gleicht Sie mit dem aktuellsten Wert des anderen Tabellenblatts ab und überträgt nur die Datensätze mit den neusten Werten. Wie bekomme ich es hin, dass Aufruf über eine Dialogbox erfolgt und diese dann aus dem Tabellenblatt der einen Datei in die neusten Werte in das Tabellenblatt einer ANDEREN Datei abgleicht und nur die neusten Werte überträgt?
Hier ein kleines Beispiel wie es aussehen soll:
Vorher:
Datei_1:
A B C
Name Alter 03.12.2020 11:11
Name Alter 01.12.2020 11:00
Name Alter 01.12.2020 10:00
Datei_2:
F G H
Name Alter 01.12.2020 10:00
Name Alter 30.11.2020 09:00
Name Alter 30.11.2020 08:11
Nachher:
Datei_1:
A B C
Name Alter 03.12.2020 11:11
Name Alter 01.12.2020 11:00
Name Alter 01.12.2020 10:00
Datei_2:
F G H
Name Alter 03.12.2020 11:11
Name Alter 01.12.2020 11:00
Name Alter 01.12.2020 10:00
Name Alter 30.11.2020 09:00
Name Alter 30.11.2020 08:11
Anbei mein Code für die Dialogbox:
Option Explicit
Sub OeffnenDialog_mit_Pfadvorgabe()
'** Anzeige des Öffnen-Dialogfensters mit voreingestelltem Pfad
'** Dimensionierung der Variablen
Dim lshThis As Worksheet, lshOther As Worksheet
Dim wb As Workbook
Dim lngZ As Long
Dim strFileName
Dim strFilter As String
'** Dateifilter definieren
strFilter = "Excel-Dateien(*.xl*), *.xl*"
'** Laufwerk und Pfad definieren, welcher geöffnet werden soll
ChDrive "C"
ChDir "C:\Projekt"
'** Den im Dialogfeld gewählten Namen auslesen
strFileName = Application.GetOpenFilename(strFilter)
'** Prüfen, ob eine gültige Datei ausgewählt wurde
If strFileName = False Then Exit Sub
'** Gewählte Datei öffnen
Set wb = Workbooks.Open(strFileName)
'**Erste Registerkarte wird ausgelesen und in die erste Registerkarte abgelegt
Set lshThis = ThisWorkbook.Sheets(1)
Set lshOther = ActiveWorkbook.Sheets(1)
'**Inhalt der Zellen A1: bis O500 wird kopiert und in F1 eingefügt
lshOther.Range("A1:O500").Copy lshThis.Range("F1")
ActiveWorkbook.Close False
End Sub
Ich bedanke mich im voraus.
Anzeige