Question

我有2个表，如下所示

表1

  AA    
  BB    
  CC    
  DD    
  EE

表2

 bb 
 aa    
 bb1    
 bb2    
 cc1    
 cc2    
 cc3

我需要帮助才能使用Excel VBA代码执行以下步骤

使用表1并循环通过表1中的每个数据并与表2进行比较
如果表2只有1个匹配项，只需从表1中同一行数据的表2值中替换表1数据
如果表2中有多个匹配项，则会提示用户选择表2中需要写入表2中的哪些数据

匹配标准如下

AA应匹配aa，aa1，aa2 ,,,,,,

BB shoud匹配bb，bb1，bb2 ,,,,,,,,

以下是我编写的代码

   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

尝试以下方法。假设您的两个表位于名为"MyData"的工作表中，其中还有一个命令按钮（CommandButton2）。添加UserForm（UserForm1），并在该UserForm中添加另一个命令按钮（CommandButton1）。

在与CommandButton2关联的模块中，复制以下代码：

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

在Userform中，以下内容：

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

需要帮助来建议如何使用Excel VBA解决

1 个答案: