Abgleich Strings, Teilsprings in 2 Arr

Sub ZweiArraysAbgleichen() Tabelle3.Activate '***** 1. Array Daten ALT Dim ZelleALT As String Dim splitStringALT() As String Dim myDataArrayALT(1 To 20, 1 To 9) As String Dim iALT As Integer, jALT As Integer Dim laRowALT As Integer laRowALT = Range("A1", Range("A2").End(xlDown)).Rows.Count ' 'Split strings to arrayALT including TRIM and CLEAN functions For iALT = 1 To laRowALT ZelleALT = WorksheetFunction.Clean(WorksheetFunction.Trim(Range("A" & iALT + 1).Value2)) splitStringALT = Split(ZelleALT, " ") For jALT = 0 To UBound(splitStringALT) myDataArrayALT(iALT, jALT + 1) = splitStringALT(jALT) Next Next '***** 2. Array Daten NEU Dim ZelleNEU As String Dim splitStringNEU() As String Dim myDataArrayNEU(1 To 4, 1 To 9) As String Dim iNEU As Integer, jNEU As Integer Dim laRowNEU As Integer laRowNEU = Range("D1", Range("D2").End(xlDown)).Rows.Count 'Split strings to arrayNEU including TRIM and CLEAN functions For iNEU = 1 To laRowNEU ZelleNEU = WorksheetFunction.Clean(WorksheetFunction.Trim(Range("D" & iNEU + 1).Value2)) splitStringNEU = Split(ZelleNEU, " ") For jNEU = 0 To UBound(splitStringNEU) myDataArrayNEU(iNEU, jNEU + 1) = splitStringNEU(jNEU) Next Next '**** Hier sollte nun der Abgleich erfolgen und in Spalte B und oder E eine Meldung erfolgen, _ aehnlich der bestehenden Anmerkungen in Spalte F ob der Artikelname _ aus D (2. Array Daten NEU) in A (1. Array Daten ALT) gefunden wurde. End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub ZweiArraysAbgleichen() Tabelle3.Activate '***** 1. Array Daten ALT Dim ZelleALT As String Dim splitStringALT() As String Dim myDataArrayALT(1 To 20, 0 To 10) As String Dim iALT As Integer, jALT As Integer Dim laRowALT As Integer laRowALT = Range("A1", Range("A2").End(xlDown)).Rows.Count ' 'Split strings to arrayALT including TRIM and CLEAN functions For iALT = 1 To laRowALT - 1 ZelleALT = WorksheetFunction.Clean(WorksheetFunction.Trim(Range("A" & iALT + 1).Value2)) myDataArrayALT(iALT, 0) = GetValue(ZelleALT) myDataArrayALT(iALT, 10) = ZelleALT splitStringALT = Split(ZelleALT, " ") For jALT = 0 To UBound(splitStringALT) myDataArrayALT(iALT, jALT + 1) = splitStringALT(jALT) Next Next '***** 2. Array Daten NEU Dim ZelleNEU As String Dim splitStringNEU() As String Dim myDataArrayNEU(1 To 14, 0 To 11) As String Dim iNEU As Integer, jNEU As Integer Dim laRowNEU As Integer laRowNEU = Range("D1", Range("D2").End(xlDown)).Rows.Count 'Split strings to arrayNEU including TRIM and CLEAN functions For iNEU = 1 To laRowNEU - 1 ZelleNEU = WorksheetFunction.Clean(WorksheetFunction.Trim(Range("D" & iNEU + 1).Value2)) myDataArrayNEU(iNEU, 0) = GetValue(ZelleNEU) myDataArrayNEU(iNEU, 10) = ZelleNEU splitStringNEU = Split(ZelleNEU, " ") myDataArrayNEU(iNEU, 11) = UBound(splitStringNEU) + 1 For jNEU = 0 To UBound(splitStringNEU) myDataArrayNEU(iNEU, jNEU + 1) = splitStringNEU(jNEU) Next Next Dim i As Long Dim j As Long Dim k As Long Dim x As Long For iNEU = 1 To laRowNEU - 1 Range("E" & iNEU + 1).Value = "nicht vorhanden in ALT" For iALT = 1 To laRowALT - 1 If myDataArrayNEU(iNEU, 0) = myDataArrayALT(iALT, 0) Then If myDataArrayNEU(iNEU, 10) = myDataArrayALT(iALT, 10) Then Range("E" & iNEU + 1).Value = "in der richtigen Reihenfolge vorhanden" Exit For Else k = 0 x = CLng(myDataArrayNEU(iNEU, 11)) For i = 1 To x For j = 1 To 9 If myDataArrayNEU(iNEU, i) = myDataArrayALT(iALT, j) Then k = k + 1 End If Next j Next i If k = x Then Range("E" & iNEU + 1).Value = "vorhanden in ALT, andere Reihenfolge" End If End If End If Next iALT Next iNEU End Sub Function GetValue(mystring As String) As Long Dim i As Long Dim x As Long x = 0 For i = 1 To Len(mystring) x = x + Asc(Mid(mystring, i, 1)) Next GetValue = x End Function

Einen schönen Guten Abend Peter,
vielleicht darf ich doch noch mal kurz stören bitte. Ich habe Deinen Code durchgearbeitet und denke (fast komplett verstanden.
Ich habe Dein VBA-Code nun auf meine 20.000 Datensätze angepasst. Eigentlich nur im Zuweisungsbereich der beiden Arrays. Auch werden nun die Zeilen farbig markiert statt eine Anmerkung in eine Spalte zu schreiben.
Er macht auch viel und eigentlich sehr gut. Und färbt die Zeilen nun entsprechend der 3 Ergebnismöglichkeiten unterschiedlich ein.
Ich habe nun ein Phänomen/Problem. So ist ein Datensatz/Artikelname "60.80 30 ON W SOFT snow-white" in beiden Spalten (nun auf unterschiedlichen Tabellenblättern) identisch vorhanden. Gleicher Artikelname und gleiche ASCII-Summe, alles identisch. Trotzdem wird er mir nun als verschieden, sprich "nicht vorhanden" angezeigt.
Ich suche schon den ganzen Tag den Fehler.
Für eventuelle Aufklärung danke ich Dir sehr herzlich!
Beste Grüße
Userbild

Anbei der nur geringfügig abgeänderte Code:
Option Explicit


Sub ZweiArraysAbgleichen()
Dim StartingTime1 As Single
StartingTime1 = Timer
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.Calculation = xlCalculationManual
'***** 1. Array Daten ALT
Tabelle2.Activate
Dim ZelleALT As String
Dim splitStringALT() As String
Dim myDataArrayALT(1 To 17894, 0 To 10) As String
Dim iALT As Integer, jALT As Integer
Dim laRowALT As Integer
laRowALT = Range("A1", Range("A2").End(xlDown)).Rows.Count
'Split strings to arrayALT including TRIM and CLEAN functions
For iALT = 1 To laRowALT - 1          '? -1
'              ZelleALT = WorksheetFunction.Clean(WorksheetFunction.Trim(Range("B" & iALT + 1).value))
ZelleALT = Range("B" & iALT + 1).Value
myDataArrayALT(iALT, 0) = GetValue(ZelleALT)
myDataArrayALT(iALT, 10) = ZelleALT
splitStringALT = Split(ZelleALT, " ")
For jALT = 0 To UBound(splitStringALT)
myDataArrayALT(iALT, jALT + 1) = splitStringALT(jALT)
Next
Next
'***** 2. Array Daten NEU
Tabelle1.Activate
Dim ZelleNEU As String
Dim splitStringNEU() As String
Dim myDataArrayNEU(1 To 17909, 0 To 11) As String
Dim iNEU As Integer, jNEU As Integer
Dim laRowNEU As Integer
laRowNEU = Range("A1", Range("A2").End(xlDown)).Rows.Count
'Split strings to arrayNEU including TRIM and CLEAN functions
For iNEU = 1 To laRowNEU - 1
'              ZelleNEU = WorksheetFunction.Clean(WorksheetFunction.Trim(Range("B" & iNEU + 1).value))
ZelleNEU = Range("B" & iNEU + 1).Value
myDataArrayNEU(iNEU, 0) = GetValue(ZelleNEU)
myDataArrayNEU(iNEU, 10) = ZelleNEU
splitStringNEU = Split(ZelleNEU, " ")
myDataArrayNEU(iNEU, 11) = UBound(splitStringNEU) + 1
For jNEU = 0 To UBound(splitStringNEU)
myDataArrayNEU(iNEU, jNEU + 1) = splitStringNEU(jNEU)
Next
Next
'Stop
'***** Ab hier Vergleich
Tabelle2.Activate
Range("A1").CurrentRegion.ClearFormats
Dim i As Long
Dim j As Long
Dim k As Long
Dim x As Long
For iNEU = 1 To laRowNEU - 1
'              Range("A" & iNEU + 1).Value = "nicht vorhanden in ALT"
Range("A" & iNEU + 1, "X" & iNEU + 1).Font.ColorIndex = 3                     ' Buchstaben ROT
Range("A" & iNEU + 1, "X" & iNEU + 1).Interior.ColorIndex = 6                ' Feld GELB
For iALT = 1 To laRowALT - 1
If myDataArrayNEU(iNEU, 0) = myDataArrayALT(iALT, 0) Then
If myDataArrayNEU(iNEU, 10) = myDataArrayALT(iALT, 10) Then
'                                   Range("A" & iNEU + 1).Value = "identisch, in der richtigen Reihenfolge vorhanden"
Range("A" & iNEU + 1, "X" & iNEU + 1).Font.ColorIndex = 10                   ' Buchstaben GRÜN
Range("A" & iNEU + 1, "X" & iNEU + 1).Interior.ColorIndex = 2                'Feld WEISS
Exit For
Else
k = 0
x = CLng(myDataArrayNEU(iNEU, 11))
For i = 1 To x
For j = 1 To 9
If myDataArrayNEU(iNEU, i) = myDataArrayALT(iALT, j) Then
k = k + 1
End If
Next j
Next i
If k = x Then
'                                          Range("A" & iNEU + 1).Value = "identisch, ABER andere Reihenfolge"
Range("A" & iNEU + 1, "X" & iNEU + 1).Font.ColorIndex = 32                   ' Buchstaben BLAU
Range("A" & iNEU + 1, "X" & iNEU + 1).Interior.ColorIndex = 4                ' Feld GRÜN
End If
End If
'Stop
End If
Next iALT
Next iNEU
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = False
Application.Calculation = xlCalculationAutomatic
Debug.Print "Benötigte Zeit: " & Format((Timer - StartingTime1) / 86400, "hh:mm:ss") & " (hh:mm:ss)"
Debug.Print " "
MsgBox "Benötigte Zeit: " & Format((Timer - StartingTime1) / 86400, "hh:mm:ss") & " (hh:mm:ss)"
End Sub


Function GetValue(mystring As String) As Long
Dim i As Long
Dim x As Long
x = 0
For i = 1 To Len(mystring)
x = x + Asc(Mid(mystring, i, 1))
Next
GetValue = x
'Stop
End Function

Beliebteste Forumthreads (12 Monate)

Abgleich Strings, Teilsprings in 2 Arr

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread