AW: Daten übertragen @Piet
04.11.2019 16:16:01
Piet
Hallo Simon
hier die überarbeitete 4. Version mit erweiteter Fehlermeldung. Geprüft wird ob Datensaetze in der Zieldatei doppelt vorkommen, oder in der Quelldatei nicht existieren. Zusaetzlich kannst du neue Daten nach Politischen Bezirken sortieren lassen, oder das Sortieren abschalten! Oben in Const steht ein "Ja" für sortieren. Setzt du da "" oder "No" rein wird nicht sortiert.
Der genannte Fehler war ein Verwechslungsfehler in der rw.Row Auswertung. (AC.Row statt AJ.Row)
Würde mich freuen wenn jetzt alles korrekt klappt.
mfg Piet
Option Explicit '31.10.2019 Piet für Herber Forum 4. Version
Dim AC As Range, lzQuell As Long
Dim AJ As Range, lzZiel As Long
Const sPfad = "132483 Quelldatei.xlsx" 'Hier bitte deinen Datei Namen angeben
Const Sort = "Ja" 'Ja/No Daten nach Politischem Bezirk sortieren
Sub Daten_übertragen_Neu() '4.Version 4.11.2019
Dim FTx1, FTx2, FTx3, FTx4 As String
Dim rw As Long, j As Long, n As Integer
Dim wbQuell As Worksheet, flg As String
With ThisWorkbook.Worksheets(1)
'Fehlermeldung Texte für Msgbox
FTx1 = " - dieser Datensatz existiert nicht in der Quelldatei - bitte prüfen!"
FTx2 = "existiert nicht in der Quelldatei ..."
FTx3 = " - dieser Datensatz ist in der Zieldatei doppelt!"
FTx4 = "doppelt in Zieldatei ..."
On Error Resume Next
'LastZell in Quell Datei ermitteln
Set wbQuell = Workbooks(sPfad).Worksheets(1)
'** 27.10. automatisches Datei Öffnen wenn Quelle Close ist!
If wbQuell Is Nothing Then 'Quell Datei ggf. Öffnen
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & sPfad
ThisWorkbook.Activate: Err = Empty
End If
On Error GoTo Fehler
Set wbQuell = Workbooks(sPfad).Worksheets(1)
lzQuell = wbQuell.Cells(Rows.Count, 1).End(xlUp).Row
lzZiel = .Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
'Vergleiche Datensaetze: Zieldatei mit Quelldatei
For Each AJ In .Range("A2:A" & lzZiel)
flg = AJ & " " & AJ.Cells(1, 2) 'Datensatz laden
For Each AC In wbQuell.Range("A2:A" & lzQuell)
If AJ.Value = AC.Value Then flg = "": Exit For
Next AC
If flg "" Then MsgBox flg & FTx1, , FTx2
Next AJ
'Prüfe doppelte Datensaetze in Zieldatei
For Each AC In .Range("A2:A" & lzZiel)
For j = AC.Row + 1 To lzZiel + 1
If .Cells(j, 1) = AC.Value Then _
MsgBox AC & " " & AC.Cells(1, 2) & FTx3, , FTx4
Next j
Next AC
For Each AC In wbQuell.Range("A2:A" & lzQuell)
'** LastZell in Ziel Datei ermitteln, aendert sich nach unten!
lzZiel = .Cells(Rows.Count, 1).End(xlUp).Row
rw = 0
'Vergleiche Spalte A Statistk Nummer "TBE"
For Each AJ In .Range("A2:A" & lzZiel)
If AJ.Value = AC.Value Then rw = AJ.Row: GoTo cpy
Next AJ
'Nicht vorhanden Daten unten anhaengen
'** 4.11. einfügen Fehler durch Jmp korrigiert
rw = lzZiel + 1: n = n + 1
.Rows(2).Copy '2.Zeile kopieren
.Rows(rw).PasteSpecial xlPasteAll
.Rows(rw).ClearContents
'MsgBox "Neu: " & AC & " " & AC.Cells(1, 2)
cpy: 'Daten in Zieltabelle einfügen, oder anhaengen!
'** 4.11. Schutz vor rw=0 Fehler eingefügt!!
If rw = 0 Then MsgBox AC & " rw=0 Auswertungs Fehler!": GoTo nx
AC.Resize(1, 6).Copy
.Cells(rw, 1).PasteSpecial xlPasteValues
AC.Cells(1, 11).Resize(1, 6).Copy
.Cells(rw, 7).PasteSpecial xlPasteValues
AC.Cells(1, 22).Resize(1, 2).Copy
.Cells(rw, 13).PasteSpecial xlPasteValues
nx: Application.CutCopyMode = False
Next AC
'bei "Ja" Sortier Programm starten
If Sort = "Ja" Then Call Statistik_sortieren
Application.ScreenUpdating = True
MsgBox n & " Daten übertragen"
End With
Exit Sub
Fehler: MsgBox "Unerwarteter Fehler aufgetreten:" & vbLf & Error()
End Sub