Mergh06
08-08-2015, 07:43 AM
Hello buddies,
My old code, 'synchronize' data. For example I have:
14106
14107
Have a good day, - the code is below:
14108
In text:
Sub ertert122()
Dim x, y(), i&, j&, k, t$, sp
x = Sheets("Raw").Range("A1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(x)
If Len(x(i, 1)) Then .Item(x(i, 1) & "|" & x(i, 2)) = x(i, 3)
Next i
For j = 4 To UBound(x, 2) Step 3
For i = 1 To UBound(x, 1)
If Len(x(i, j)) Then
t = x(i, j) & "|" & x(i, j + 1)
If .Exists(t) Then .Item(t) = .Item(t) & "~" & x(i, j + 2)
End If
Next i
Next j: i = 0
ReDim y(1 To .Count, 1 To UBound(x, 2) / 3 + 2)
For Each k In .keys
If InStr(.Item(k), "~") Then
sp = Split(.Item(k), "~")
If UBound(sp) = UBound(x, 2) / 3 - 1 Then
i = i + 1
For j = 0 To UBound(sp): y(i, j + 3) = sp(j): Next j
sp = Split(k, "|"): y(i, 1) = sp(0): y(i, 2) = sp(1)
End If
End If
Next k
End With
If i = 0 Then MsgBox "Oops, there are no matching": Exit Sub
With Sheets("Result").Range("A1")
.CurrentRegion.ClearContents
.Resize(i, UBound(y, 2)).Value = y(): .Parent.Activate
End With
End Sub
- best
My old code, 'synchronize' data. For example I have:
14106
14107
Have a good day, - the code is below:
14108
In text:
Sub ertert122()
Dim x, y(), i&, j&, k, t$, sp
x = Sheets("Raw").Range("A1").CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(x)
If Len(x(i, 1)) Then .Item(x(i, 1) & "|" & x(i, 2)) = x(i, 3)
Next i
For j = 4 To UBound(x, 2) Step 3
For i = 1 To UBound(x, 1)
If Len(x(i, j)) Then
t = x(i, j) & "|" & x(i, j + 1)
If .Exists(t) Then .Item(t) = .Item(t) & "~" & x(i, j + 2)
End If
Next i
Next j: i = 0
ReDim y(1 To .Count, 1 To UBound(x, 2) / 3 + 2)
For Each k In .keys
If InStr(.Item(k), "~") Then
sp = Split(.Item(k), "~")
If UBound(sp) = UBound(x, 2) / 3 - 1 Then
i = i + 1
For j = 0 To UBound(sp): y(i, j + 3) = sp(j): Next j
sp = Split(k, "|"): y(i, 1) = sp(0): y(i, 2) = sp(1)
End If
End If
Next k
End With
If i = 0 Then MsgBox "Oops, there are no matching": Exit Sub
With Sheets("Result").Range("A1")
.CurrentRegion.ClearContents
.Resize(i, UBound(y, 2)).Value = y(): .Parent.Activate
End With
End Sub
- best