AW: Zelleninhalt vergleichen
22.05.2014 15:01:58
Hajo_Zi
ich habe es jetzt nicht in der tiefe geprüft.
Option Explicit ' Variablendefinition erforderlich
Sub Tabellen_Vergleich06()
'* H. Ziplies *
'* 22.05.14 *
'* erstellt von HajoZiplies@web.de *
'* 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("Tabelle1") ' setzen Tabelle1
Set WsT2 = Worksheets("Tabelle2") ' 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("A1:A" & LoLetzte1).Find(WsT2.Cells(LoI, 2), _
WsT1.Range("A" & LoLetzte1), , xlWhole, , xlNext)
If RaFound Is Nothing Then ' Begriff gefunden
WsT2.Rows(LoI).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
Gruß Hajo