Need help to advice how to solve using Excel VBA - vba

Question

I have 2 tables as shown below
Table 1
AA
BB
CC
DD
EE
Table 2
bb
aa
bb1
bb2
cc1
cc2
cc3
I need help to do the below steps using Excel VBA code
Use Table 1 and loop thru each data in table 1 and compare to Table 2
If table 2 only have 1 match, just replace the Table 1 data from the table 2 value on the same row of data from table 1
If have multiple match from table 2, them prompt user to select which data from table 2 need to be written in table 1
Matching Criteria are as follows
AA should match to aa,aa1,aa2,,,,,,
BB shoud match bb,bb1,bb2,,,,,,,,
Below is the code that I have written
Private Sub CommandButton2_Click()
Dim attr1 As Range, data1 As Range
Dim item1, item2, item3, lastRow, lastRow2
Dim UsrInput, UsrInput2 As Variant
Dim Cnt As Integer, LineCnt As Integer
Dim MatchData(1 To 9000) As String
Dim i As Integer, n As Integer, j As Integer, p As Integer
Dim counter1 As Integer, counter2 As Integer
Dim match1(1 To 500) As Integer
Dim matchstr1(1 To 500) As String
Dim tmpstr1(1 To 500) As String
Dim storestr(1 To 500) As String
Dim tmpholderstr As String
counter1 = 1
counter2 = 0
j = 0
p = 0
tmpholderstr = ""
For i = 1 To 500
storestr(i) = ""
Next i
For i = 1 To 500
tmpstr1(i) = ""
Next i
For i = 1 To 500
matchstr1(i) = ""
Next i
For i = 1 To 500
match1(i) = 0
Next i
For i = 1 To 9000
MatchData(i) = ""
Next i
UsrInput = InputBox("Enter Atribute Column")
UsrInput2 = InputBox("Enter Column Alphabet to compare")
With ActiveSheet
lastRow = .Cells(.Rows.Count, UsrInput).End(xlUp).Row
'MsgBox lastRow
End With
With ActiveSheet
lastRow2 = .Cells(.Rows.Count, UsrInput2).End(xlUp).Row
'MsgBox lastRow
End With
Set attr1 = Range(UsrInput & "2:" & UsrInput & lastRow)
Set data1 = Range(UsrInput2 & "2:" & UsrInput2 & lastRow2)
'Debug.Print lastRow
'Debug.Print lastRow2
For Each item1 In attr1
item1.Value = Replace(item1.Value, " ", "")
Next item1
For Each item1 In attr1
If item1.Value = "" Then Exit For
counter1 = counter1 + 1
item1.Value = "*" & item1.Value & "*"
For Each item2 In data1
If item2 = "" Then Exit For
If item2 Like item1.Value Then
counter2 = counter2 + 1
match1(counter2) = counter1
matchstr1(counter2) = item2.Value
tmpstr1(counter2) = item1.Value
Debug.Print item1.Row
Debug.Print "match1[" & counter2; "] = " & match1(counter2)
Debug.Print "matchstr1[" & counter2; "] = " & matchstr1(counter2)
Debug.Print "tmpstr1[" & counter2; "] = " & tmpstr1(counter2)
End If
Next item2
Next item1
' Below is the code that go thru the array and try to write to table 1
' But it is not working as expected.
For n = 1 To 500
If matchstr1(n) = "" Then Exit For
If match1(n) <> match1(n + 1) Then
Range("K" & match1(n)) = matchstr1(n)
Else
i = 0
For j = n To 300
If matchstr1(j) = "" Then Exit For
i = i + 1
If match1(j) = match1(j + 1) Then
tmpstr1(i) = matchstr1(j)
End If
Next j
End If
Next n
End Sub

Answer 1

Try the following. Your two tables are suppose to be in a sheet named "MyData", where there is also a command button (CommandButton2). Add also a UserForm (UserForm1), and in that UserForm add another command button (CommandButton1).
In the module associated with CommandButton2, copy the following code:
Public vMyReplacementArray() As Variant
Public iNumberOfItems As Integer
Public vUsrInput As Variant, vUsrInput2 As Variant
Public lLastRow As Long, lLastRow2 As Long
Public rAttr1 As Range, rData1 As Range, rItem1 As Range, rItem2 As Range
Public iCounter1 As Integer
Sub Button2_Click()
vUsrInput = InputBox("Enter Atribute Column")
vUsrInput2 = InputBox("Enter Column Alphabet to compare")
With ActiveSheet
lLastRow = .Cells(.Rows.Count, vUsrInput).End(xlUp).Row
End With
With ActiveSheet
lLastRow2 = .Cells(.Rows.Count, vUsrInput2).End(xlUp).Row
End With
Set rAttr1 = Range(vUsrInput & "2:" & vUsrInput & lLastRow)
Set rData1 = Range(vUsrInput2 & "2:" & vUsrInput2 & lLastRow2)
ReDim vMyReplacementArray(1 To 1) As Variant
For Each rItem1 In rAttr1
For Each rItem2 In rData1
If (InStr(1, rItem2, rItem1, vbTextCompare)) > 0 Then
vMyReplacementArray(UBound(vMyReplacementArray)) = rItem1.Value & "-" & rItem2.Value
ReDim Preserve vMyReplacementArray(1 To UBound(vMyReplacementArray) + 1) As Variant
End If
Next rItem2
Next rItem1
iNumberOfItems = UBound(vMyReplacementArray) - LBound(vMyReplacementArray)
UserForm1.Show
End Sub
And in the Userform, the following:
Dim k As Integer
Private Sub UserForm_initialize()
Dim myElements() As String
Dim theLabel As Object
Dim rad As Object
Class1 = ""
k = 1
For i = 1 To iNumberOfItems
myElements = Split(vMyReplacementArray(i), "-")
If myElements(0) <> Class1 Then
Set theLabel = UserForm1.Controls.Add("Forms.Label.1", "Test" & i, True)
theLabel.Caption = myElements(0)
theLabel.Left = 80 * k
theLabel.Width = 20
theLabel.Top = 10
k = k + 1
j = 1
End If
Set rad = UserForm1.Controls.Add("Forms.OptionButton.1", "radio" & j, True)
If j = 1 Then
rad.Value = True
End If
rad.Caption = myElements(1)
rad.Left = 80 * (k - 1)
rad.Width = 60
rad.GroupName = k - 1
rad.Top = 50 + 20 * j
j = j + 1
Class1 = myElements(0)
Next i
End Sub
Private Sub CommandButton1_Click()
Dim ctrl As MSForms.Control
Dim dict(5, 1)
Dim i
'## Iterate the controls, and associates the GroupName to the Button.Name that's true.
i = 0
For Each ctrl In Me.Controls
If TypeName(ctrl) = "OptionButton" Then
If ctrl.Value = True Then
dict(i, 0) = ctrl.GroupName
dict(i, 1) = ctrl.Caption
i = i + 1
End If
End If
Next
'For i = 0 To k
'MsgBox "grupo: " & dict(i, 0) & "elem: " & dict(i, 1)
'Next
j = 0
For i = 1 To iNumberOfItems
myElements = Split(vMyReplacementArray(i), "-")
For Each rItem1 In rAttr1
If rItem1 = myElements(0) Then
rItem1 = dict(j, 1)
j = j + 1
End If
Next
Next i
End Sub