VBA Vergleich

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Günter,
das sollte z. B. so funktionieren:

Option Explicit
Public Sub Abgleich()
Dim WkSh_A    As Worksheet
Dim WkSh_N    As Worksheet
Dim WkSh_F    As Worksheet
Dim lZeile_A  As Long
Dim lZeile_F  As Long
Dim rZelle    As Range
   Application.ScreenUpdating = False

   Set WkSh_A = ThisWorkbook.Worksheets("Alt")
   Set WkSh_N = ThisWorkbook.Worksheets("Neu")
   Set WkSh_F = ThisWorkbook.Worksheets("Fehlende in Neu")

   lZeile_F = 12 ' die Start-Zeile in Fehlende in Neu minus 1

   For lZeile_A = 13 To WkSh_A.Cells(Rows.Count, 14).End(xlUp).Row
      With WkSh_N.Columns(14)
         Set rZelle = .Find(What:=WkSh_A.Range("N" & lZeile_A).Value, LookAt:=xlWhole, _
            LookIn:=xlValues)
         If rZelle Is Nothing Then
            lZeile_F = lZeile_F + 1
            WkSh_A.Rows(lZeile_A).Copy Destination:=WkSh_F.Rows(lZeile_F)
         End If
      End With
   Next lZeile_A

   Application.ScreenUpdating = True
End Sub
Gruß Peter

Hallo,
so schnell war ich mit meiner Version nicht fertig.

Sub Liste_Neu()
Dim ArrayAlt, ArrayNeu, ArrayTmp(), oDic As Object
Dim nCount As Long, lngCol As Long, lngRow As Long

Set oDic = CreateObject("Scripting.Dictionary")

With Tabelle1 'Alt 
 ArrayAlt = .Range("N13", .Cells(.Rows.Count, 14).End(xlUp)).Value2
 For nCount = 1 To Ubound(ArrayAlt)
    oDic(ArrayAlt(nCount, 1)) = 0
 Next nCount
 Erase ArrayAlt
End With

With Tabelle2 'Neu 
    ArrayNeu = .Range("A13", .Cells(.Rows.Count, 14).End(xlUp)).Value2
    Redim Preserve ArrayTmp(1 To Ubound(ArrayNeu, 2), 1 To Ubound(ArrayNeu))
    For nCount = 1 To Ubound(ArrayNeu)
        If Not oDic.exists(ArrayNeu(nCount, 14)) Then
            lngRow = lngRow + 1
            For lngCol = 1 To 14
                ArrayTmp(lngCol, lngRow) = ArrayNeu(nCount, lngCol)
            Next lngCol
        End If
    Next nCount
End With


With Tabelle3 'Fehlende in Neu 
    .Range("A13", .Cells(.Rows.Count, 14)).ClearContents
    If lngRow > 0 Then
        Redim Preserve ArrayTmp(1 To Ubound(ArrayTmp), 1 To lngRow)
        ArrayTmp = Application.Transpose(ArrayTmp)
        
        With .Range("A13").Resize(lngRow, Ubound(ArrayTmp, 2))
            .Cells = ArrayTmp
            .EntireColumn.AutoFit
        End With
    End If
End With

End Sub

Gruß Tino

Sub Liste_Neu() Dim ArrayAlt, ArrayNeu, ArrayTmp(), oDic As Object Dim nCount As Long, lngCol As Long, lngRow As Long Set oDic = CreateObject("Scripting.Dictionary") With Tabelle1 'Alt ArrayAlt = .Range("N13", .Cells(.Rows.Count, 14).End(xlUp)).Value2 For nCount = 1 To Ubound(ArrayAlt) oDic(ArrayAlt(nCount, 1)) = 0 Next nCount Erase ArrayAlt End With With Tabelle2 'Neu ArrayNeu = .Range("A13", .Cells(.Rows.Count, 14).End(xlUp)).Value2 Redim Preserve ArrayTmp(1 To Ubound(ArrayNeu, 2), 0 To Ubound(ArrayNeu)) For nCount = 1 To Ubound(ArrayNeu) If Not oDic.exists(ArrayNeu(nCount, 14)) Then lngRow = lngRow + 1 For lngCol = 1 To 14 ArrayTmp(lngCol, lngRow - 1) = ArrayNeu(nCount, lngCol) Next lngCol End If Next nCount End With With Tabelle3 'Fehlende in Neu .Range("A13", .Cells(.Rows.Count, 14)).ClearContents If lngRow > 0 Then Redim Preserve ArrayTmp(1 To Ubound(ArrayTmp), 0 To lngRow) ArrayTmp = Application.Transpose(ArrayTmp) With .Range("A13").Resize(lngRow, Ubound(ArrayTmp, 2)) .Cells = ArrayTmp .EntireColumn.AutoFit End With .Select End If End With End Sub

Beliebteste Forumthreads (12 Monate)

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread