Vergleichen benötige dringend Rat
15.07.2015 12:23:11
Peter
wünsche einen schönen Tag.
Habe vor kurzem die u.a. Fragen gestellt und eine einwandfrei Antwort erhalten, bis auf eine Kleinigkeit.
Wenn die Tabelle keine Unterschiede aufweist, also alles identisch ist, dann folgt Laufzeitfehler 9. Wer kann mir hier bitte helfen?
Ausserdem sollen zwei Tabellen verglichen werden und die Werte der Anzahl aus Tabelle2_gewählte2 in Spalte Code einsortiert und Anzahl entsprechend dem Code in Spalte Anzahl2 eingefügt werden.
Guten Morgen
ich benötige wieder einmal die Hilfe der Fachleute.
Ich habe eine Excel-Datei mit vier Tabellen. In der 1. sind alle Codes vorhanden.
In der 2. bestimmte ausgewählte Codes. Nun sollen die Codes, die in diesen beiden
Tabellen vorhanden sind und in Anzahl Wert vorhanden ist mit Code und Anzahl der Reihe nach in die Tabelle 3 eingefügt werden. Die aus der Tabelle 2, die nicht mit der Tabelle 1 identisch sind und die keinen Wert bei Anzahl aufweisen, sollen
in die Tabelle 4 eingefügt werden.
Besten Dank für Eure Hilfe.
Noch ein Hinweis: Die Tabellen 1 und 2 sind unterschiedlich lang, je nachdem, was
eingespielt wird.
https://www.herber.de/bbs/user/98159.xlsm
Gruss
Peter
Hallo Peter,
per VBA.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub compare()
Dim varAll As Variant, varChoosen As Variant, varError() As Variant, varIdentic() As Variant
Dim lngN As Long, lngI As Long, lngE As Long
Dim vntR As Variant
With Sheets("Tabelle1_alle")
varAll = .Range("A2:A" & Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row))
End With
With Sheets("Tabelle2_gewählte")
varChoosen = .Range("A2:B" & Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row))
End With
Sheets("Tabelle4_Fehler").Range("A2:B1000") = ""
Sheets("Tabelle3_identisch").Range("A2:B1000") = ""
For lngN = 1 To UBound(varChoosen, 1)
If varChoosen(lngN, 1) "" Then
vntR = Application.Match(varChoosen(lngN, 1), varAll, 0)
If IsError(vntR) Or varChoosen(lngN, 2) = "" Then
Redim Preserve varError(lngE)
varError(lngE) = Array(varChoosen(lngN, 1), varChoosen(lngN, 2))
lngE = lngE + 1
End If
If Not IsError(vntR) And varChoosen(lngN, 2) "" Then
Redim Preserve varIdentic(lngI)
varIdentic(lngI) = Array(varChoosen(lngN, 1), varChoosen(lngN, 2))
lngI = lngI + 1
End If
End If
Next
If lngI > 0 Then _
Sheets("Tabelle4_Fehler").Range("A2").Resize(UBound(varError) + 1, 2) = _
Application.Transpose(Application.Transpose(varError))
If lngE > 0 Then _
Sheets("Tabelle3_identisch").Range("A2").Resize(UBound(varIdentic, 1) + 1, 2) = _
Application.Transpose(Application.Transpose(varIdentic))
End Sub
https://www.herber.de/bbs/user/98837.xlsm
Gruss Peter