Hallo zusammen,
ich möchte gerne mit folgendem Code (aus Forum hergeleitet) das die differenz aus z. B Spalte B der Tabelle „ArbTab“ zu Spalte B aus Tabelle „Fehler“ in Tabelle3 kopiert wird. Mein Problem hierbei ist:
"Wert aus ArbTab zu Fehler mit <> irgendwo einzubringen um die Unpaarigen Datensätzt in Tabelle3 wieder zu finden (kopiert)
Bin für jeden Tipp dankbar! Gruß
Sub Tabellen_Vergleich06() '*********************************************** '* H. Ziplies * '* 02.06.07 * '* erstellt von [email protected] * '* http://Hajo-Excel.de/ * '*********************************************** Dim LoI As Long ' 1. Schleifenvariable Dim LoLetzte1 As Long ' Variable letzte Zeile in Spalte A Dim LoLetzte2 As Long ' Variable letzte Zeile in Spalte B Dim Loletzte3 As Long ' Variable letzte Zeile in Tabelle3 Dim RaFound As Range ' Suchergebnis Dim WsT1 As Worksheet ' Variable Tabelle1 Original Dim WsT2 As Worksheet ' Variable Tabelle2 Kopie Application.ScreenUpdating = False ' Bildschirmaktualisierung aus Set WsT1 = Worksheets("ArbTab") ' setzen Tabelle1 Set WsT2 = Worksheets("Fehler") ' setzen Tabelle2 With WsT1 ' letzte Zeile Spalte A im Original ermitteln LoLetzte1 = IIf(IsEmpty(.Cells(Rows.Count, 1)), _ .Cells(Rows.Count, 1).End(xlUp).Row, .Rows.Count) End With With WsT2 ' letzte Zeile Spalte B in Kopie ermitteln LoLetzte2 = IIf(IsEmpty(.Cells(Rows.Count, 2)), _ .Cells(Rows.Count, 2).End(xlUp).Row, .Rows.Count) End With For LoI = 1 To LoLetzte2 ' Schleife über Kopie If WsT2.Cells(LoI, 2) <> "" Then Set RaFound = WsT1.Range("B1:B" & LoLetzte1).Find(WsT2.Cells(LoI, 2), _ WsT1.Range("B" & LoLetzte1), , xlWhole, , xlNext) If Not RaFound Is Nothing Then ' Begriff gefunden WsT1.Rows(RaFound.Row).Copy ' gefundene Zeile kopieren With Worksheets("Tabelle3") ' letzte belegte Zeile in Tabelle 3 ermitteln Loletzte3 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1 ' ermittelte Zeilennummer mit max. Anzahl vergleichen If Loletzte3 > Rows.Count Then MsgBox "In Tabelle3 ist keine Zeile mehr frei" ' Zwischenspeicher löschen Application.CutCopyMode = False Exit Sub End If ' Werte übertragen .Rows(Loletzte3).PasteSpecial Paste:=xlValues ' Formate übertragen .Rows(Loletzte3).PasteSpecial Paste:=xlFormats ' Werte übertragen in die gleiche Zeile wie Tabelle1 '.Rows(RaFound.Row).PasteSpecial Paste:=xlValues ' Formate übertragen in die gleiche Zeile wie Tabelle1 '.Rows(RaFound.Row).PasteSpecial Paste:=xlFormats End With End If End If Next LoI Application.CutCopyMode = False ' Zwischenspeicher löschen Application.ScreenUpdating = True ' Bildschirmaktualisierung ein End Sub
