VBA Daten übertragen/löschen

Hallo Zusammen,
ich benötige euere Hilfe.
Ich lade eine Datei per Export in eine Excel, das funktioniert schon mal.
Der Reiten mit den geladenen Daten heißt "Sheet1".
Nun sollen per VBA folgende Daten übernommen werden, aber nur wenn diese im Reiter Mandantenverwaltung noch nicht vorhanden sind.
In diesem Beispiel Mandant E, Mandant F, Mandant G. Also soll das VBA prüfen ob es den Namen, also spalte F im Reiter Sheet 1 schon im Reiter Mandantenverwaltung gibt., Spalte B.
Wenn nein, soll er nichts tun. Wenn ja soll er die Daten in die erste Leere Zeile einfügen, aber nur Spalte C, D, F und H.
Danach soll eine Msgbox anzeigen: es wurden XX viele Mandanten hinzugefügt. Also nur die neuen.
Andersherum, wenn im Reiter Mandantenverwaltung ein Mandant besteht der aber im Sheet 1 nicht mehr zu finden ist, soll er per Msgbox fragen ob er den Mandanten löschen möchte, ja oder nein. Bei nein nichts, bei ja die ganze Zeile löschen.
Hier die Muster Datei.
https://www.herber.de/bbs/user/143701.xlsm
Ich bin um jeden Tipp Dankbar!
Vielen lieben Dank im Voraus!
Verregnete Grüße
Mone

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Code: [Cc][+][-] Option Explicit Sub Übertragen() Dim WShZ As Worksheet, WShQ As Worksheet Dim iGefunden As Long, iOutZeile As Long, iZeile As Long Dim iAnz As Integer, sSuch As String With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual End With ' Referenzen setzen Set WShZ = ThisWorkbook.Sheets("Mandatenverwaltung") ' Zieltabelle Set WShQ = ThisWorkbook.Sheets("Sheet1") ' Quelltabelle On Error Resume Next ' Neue Mandanten aufnehmen For iZeile = 2 To WShQ.Cells(Rows.Count, 2).End(xlUp).Row ' Alle Zeilen durchgehen iGefunden = 0 sSuch = WShQ.Cells(iZeile, "F").Value iGefunden = WorksheetFunction.Match(sSuch, WShZ.Range("B:B"), 0) If iGefunden = 0 Then ' Suchbegriff gefunden? For iOutZeile = 7 To WShZ.Cells(Rows.Count, "B").End(xlUp).Row If WShZ.Cells(iOutZeile, "B").Value = "" Then Exit For Next iOutZeile With WShZ.Cells(iOutZeile, "A") ' Daten übernehmen .Offset(0, 1).Value = WShQ.Cells(iZeile, "F").Value .Offset(0, 2).Value = WShQ.Cells(iZeile, "H").Value .Offset(0, 3).Value = WShQ.Cells(iZeile, "D").Value .Offset(0, 4).Value = WShQ.Cells(iZeile, "C").Value End With iAnz = iAnz + 1 End If Next iZeile ' Alte Mandanten löschen For iZeile = 7 To WShZ.Cells(Rows.Count, "B").End(xlUp).Row ' Alle Zeilen durchgehen iGefunden = 0 sSuch = WShZ.Cells(iZeile, "B").Value If sSuch = "" Then Exit For iGefunden = WorksheetFunction.Match(sSuch, WShQ.Range("F:F"), 0) If iGefunden = 0 Then ' Suchbegriff gefunden? If MsgBox("Der Mandant '" & sSuch & "' ist im Sheets1 nicht vorhanden!" _ & vbCr & vbCr & "Soll die Zeile gelöscht werden?", _ vbYesNo Or vbQuestion, "Datenübernahme") = vbYes Then WShZ.Cells(iZeile, "A").EntireRow.Delete End If End If Next iZeile With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic End With ' Abschlussmeldungen If iAnz = 0 Then MsgBox "Es wurden keine neuen Mandanten übernommen!", vbExclamation, "Übertrag" Else MsgBox iAnz & " neue Mandanten wurden übernommen!", vbExclamation, "Übertrag" End If End Sub

Hallo Mone,
hier noch mal ein Update.
Die Löschung erfolgt nun aufgrund eines Hinweises von AlterDresdener von hinten, da sonst evtl. eine direkt hintereinander zu löschende Position wegen der Zeilenverschiebung nicht gelöscht wird.

Code:


[Cc][+][-]

Option Explicit

Sub Übertragen()
  Dim WShZ As Worksheet, WShQ As Worksheet
  Dim iGefunden As Long, iOutZeile As Long, iZeile As Long
  Dim iAnz As Integer, sSuch As String
  
  With Application
     .ScreenUpdating = False
     .EnableEvents = False
     .Calculation = xlCalculationManual
  End With
  
' Referenzen setzen
  Set WShZ = ThisWorkbook.Sheets("Mandatenverwaltung")        ' Zieltabelle
  Set WShQ = ThisWorkbook.Sheets("Sheet1")                    ' Quelltabelle
  On Error Resume Next

' Neue Mandanten aufnehmen
  For iZeile = 2 To WShQ.Cells(Rows.Count, 2).End(xlUp).Row   ' Alle Zeilen durchgehen
      iGefunden = 0
      sSuch = WShQ.Cells(iZeile, "F").Value
      iGefunden = WorksheetFunction.Match(sSuch, WShZ.Range("B:B"), 0)
      If iGefunden = 0 Then                                   ' Suchbegriff gefunden?
         For iOutZeile = 7 To WShZ.Cells(Rows.Count, "B").End(xlUp).Row
            If WShZ.Cells(iOutZeile, "B").Value = "" Then Exit For
         Next iOutZeile
         With WShZ.Cells(iOutZeile, "A")                      ' Daten übernehmen
            .Offset(0, 1).Value = WShQ.Cells(iZeile, "F").Value
            .Offset(0, 2).Value = WShQ.Cells(iZeile, "H").Value
            .Offset(0, 3).Value = WShQ.Cells(iZeile, "D").Value
            .Offset(0, 4).Value = WShQ.Cells(iZeile, "C").Value
         End With
         iAnz = iAnz + 1
      End If
  Next iZeile

' Alte Mandanten löschen
  For iZeile = WShZ.Cells(Rows.Count, "B").End(xlUp).Row To 7 Step -1
      iGefunden = 0
      sSuch = WShZ.Cells(iZeile, "B").Value
      If sSuch <> "" Then
         iGefunden = WorksheetFunction.Match(sSuch, WShQ.Range("F:F"), 0)
         If iGefunden = 0 Then                                   ' Suchbegriff gefunden?
            If MsgBox("Der Mandant '" & sSuch & "' ist im Sheets1 nicht vorhanden!" _
                     & vbCr & vbCr & "Soll die Zeile gelöscht werden?", _
                     vbYesNo Or vbQuestion, "Datenübernahme") = vbYes Then
               WShZ.Cells(iZeile, "A").EntireRow.Delete
            End If
         End If
      End If
  Next iZeile
  
  With Application
     .ScreenUpdating = True
     .EnableEvents = True
     .Calculation = xlCalculationAutomatic
  End With
  
' Abschlussmeldungen
  If iAnz = 0 Then
     MsgBox "Es wurden keine neuen Mandanten übernommen!", vbExclamation, "Übertrag"
  Else
     MsgBox iAnz & " neue Mandanten wurden übernommen!", vbExclamation, "Übertrag"
  End If
End Sub

_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz

Sub Uebernehmen() Dim shQuell As Object, shZiel As Object, zeile As Long, found As Variant Dim anzcopy As Long, anzDel As Long, zeiZiel As Long Set shQuell = ThisWorkbook.Sheets("Sheet1") Set shZiel = ThisWorkbook.Sheets("Mandatenverwaltung") 'sollte Mandantenverwaltung sein? With shZiel 'erste freie zelle bestimmen If .FilterMode Then .ShowAllData zeiZiel = 7 While Not IsEmpty(.Cells(zeiZiel, 2)) zeiZiel = zeiZiel + 1 Wend For zeile = 2 To shQuell.Cells(shQuell.Rows.Count, 1).End(xlUp).Row Set found = .Columns(2).Find(what:=shQuell.Cells(zeile, 6), lookat:=xlWhole) If found Is Nothing Then .Cells(zeiZiel, 2) = shQuell.Cells(zeile, 6) .Cells(zeiZiel, 3) = shQuell.Cells(zeile, 8) .Cells(zeiZiel, 4) = shQuell.Cells(zeile, 4) .Cells(zeiZiel, 5) = shQuell.Cells(zeile, 3) zeiZiel = zeiZiel + 1 anzcopy = anzcopy + 1 End If Next zeile For zeile = zeiZiel - 1 To 7 Step -1 Set found = shQuell.Columns(6).Find(what:=.Cells(zeile, 2), lookat:=xlWhole) If found Is Nothing Then If MsgBox("Mandanten " & .Cells(zeile, 2) & " löschen?", _ vbYesNo + vbDefaultButton2, "wirklich löschen?") = vbYes Then anzDel = anzDel + 1 .Rows(zeile).Delete shift:=xlUp End If End If Next zeile End With MsgBox anzcopy & " Einträge hinzugefügt, " & anzDel & " Einträge gelöscht" End Sub

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread