AW: VBA keine Duplikate exportieren
02.06.2023 02:38:52
Ulf
Option Explicit
Const conZielDatei As String = "AM_Ziel.xlsx"
Function IsWorkbookOpen(strWB As String) As Boolean
On Error Resume Next
IsWorkbookOpen = Not Workbooks(strWB) Is Nothing
End Function
Public Sub EXPORT()
On Local Error GoTo Abbruch
'Workbooks
Dim wbZiel As Workbook
Dim wbQuelle As Workbook
'Worksheets
Dim wksQuelle As Worksheet
Dim wksZiel As Worksheet
'Quell-und/oder Zielpfad
Dim strPfad As String
'Die Kollektion unserer neuen Daten, nimmt Ranges auf
'Array ginge auch
Dim col As New Collection
'Zeilen in Quelle und Ziel
Dim lngAnzahlQuelle As Long
Dim lngAnzahlZiel As Long
'Zählerschleife
Dim lngZählerQuelle As Long
Dim lngZählerZiel As Long
'Quell-und Zielbereich
Dim rgQuelle As Range
Dim rgZiel As Range
Dim mbrWeiter As VBA.VbMsgBoxResult
'True bei Fund sonst false
Dim bGefunden As Boolean
'Die Anzahl der zu Übertragenden
Dim lngÜbertragen As Long
'Index aus Spalte 1
Dim lngNr As Long
'Bereich in den übernommen wird
Dim rgNeu As Range
'Schleifenzähler der zu übernehmenden Daten
Dim lngZähler As Long
'Spalte aus Kollektion
Dim lngSpalte As Long
'Anzahl der Spalten
Dim lngSpalten As Long
Set wbQuelle = ThisWorkbook
'Hier im Original, bei mir im gleichen Ordner wie Quelle
'strPfad = "C:\"
'Auskommentieren vor Start und ggf obige Zeile aktivieren !
strPfad = wbQuelle.Path & "\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
mbrWeiter = MsgBox("Daten exportieren?", vbQuestion + vbOKCancel, "A C H T U N G!!!")
If mbrWeiter > vbOK Then
Exit Sub
End If
If Not IsWorkbookOpen(conZielDatei) Then
Set wbZiel = Workbooks.Open(Filename:=strPfad & conZielDatei)
Else
Set wbZiel = Workbooks(conZielDatei)
End If
Set wksQuelle = wbQuelle.Worksheets("TB_Quelle")
lngAnzahlQuelle = wksQuelle.UsedRange.Rows.Count - 1
Set rgQuelle = wksQuelle.Range("A2:D" & CStr(lngAnzahlQuelle))
Set wksZiel = wbZiel.Worksheets(1)
lngAnzahlZiel = wksZiel.UsedRange.Rows.Count - 1
Set rgZiel = wksZiel.Range("A2:D" & CStr(lngAnzahlZiel))
For lngZählerQuelle = 1 To lngAnzahlQuelle
bGefunden = False
lngNr = rgQuelle.Cells(lngZählerQuelle, 1).Value
For lngZählerZiel = 1 To lngAnzahlZiel
If rgZiel.Cells(lngZählerZiel, 1).Value = lngNr Then
bGefunden = True
Exit For
End If
Next lngZählerZiel
If Not bGefunden Then
Dim rgBereich As Range
Set rgBereich = rgQuelle.Range("A" & CStr(lngZählerQuelle) & ":D" & CStr(lngZählerQuelle))
col.Add rgBereich
Set rgBereich = Nothing
lngÜbertragen = lngÜbertragen + 1
End If
Next lngZählerQuelle
For lngZähler = 1 To lngÜbertragen
Set rgNeu = wksZiel.Range("A" & CStr(lngAnzahlZiel + 1 + lngZähler) & ":D" & CStr(lngAnzahlZiel + 1 + lngZähler))
For lngSpalten = 1 To rgNeu.Columns.Count
rgNeu.Cells(1, lngSpalten).Value = col.Item(lngZähler).Cells(1, lngSpalten).Value
Next
Next lngZähler
Beenden:
Set rgNeu = Nothing
Set col = Nothing
Set rgQuelle = Nothing
Set rgZiel = Nothing
Set wksQuelle = Nothing
Set wksZiel = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic 'automat.Berechnung einschalten
If lngÜbertragen = 0 Then
MsgBox "Es wurden keine Zeilen exportiert", vbInformation + vbOKOnly, "Export"
Else
MsgBox "Es wurden " & CStr(lngÜbertragen) & " Zeilen exportiert", vbInformation + vbOKOnly, "Export"
End If
Exit Sub
Abbruch:
Resume Beenden
End Sub