Question

我正在尝试创建一个宏，如果A列Sheet1中的名称与Sheet2中A列中的名称相对应，则将B列中的数据从Sheet1传递到Sheet2。代码的第一部分工作正常，但是第二部分是“直到”循环，这是问题所在。使用我目前拥有的代码，循环将在A列中的第一个名称的外部循环和内部循环中运行，但是对于A列中的其余名称，则不会通过外部循环。代码如下：

Sub PullNames()

Dim A As Range
Dim B As Range
Dim C As Range
Dim A2 As Range
Dim B2 As Range
Dim C2 As Range
Dim LastA As Long
Dim LastB As Long
Dim LastC As Long
Dim LastA2 As Long
Dim CheckName As String
Dim CheckName2 As String
Dim count As Long


LastA = Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Row
LastB = Sheets("Sheet1").Cells(Rows.count, 2).End(xlUp).Row
LastC = Sheets("Sheet1").Cells(Rows.count, 3).End(xlUp).Row
count = 2

Set A = Sheets("Sheet1").Range("A2:A" & LastA)
Set B = Sheets("Sheet1").Range("B2:B" & LastB)
Set C = Sheets("Sheet1").Range("C2:c" & LastC)
Set A2 = Sheets("Sheet2").Range("A" & count)
Set B2 = Sheets("Sheet2").Range("B" & count)
Set C2 = Sheets("Sheet2").Range("C" & count)

Sheets("Sheet2").Activate
A2.Activate

    A.Copy Destination:=A2
    A2.RemoveDuplicates Columns:=1, Header:=xlNo
    A2.Columns.AutoFit


Sheets("Sheet1").Activate

LastA2 = Sheets("Sheet2").Cells(Rows.count, 1).End(xlUp).Row

Do Until count > LastA
    CheckName = Sheets("Sheet1").Range("A" & count)
    Name = CheckName

        'creates a loop for the macro to go through the names on Sheet2
        If count < LastA2 Then
            CheckName2 = A2
            Name2 = CheckName2
                If Name = Name2 Then
                    B2 = B.Value
                End If

        count2 = count2 + 1
        End If

count = count + 1
Loop


End Sub

Answer 1

您只有一个循环。您的注释开始“创建循环”的地方不是循环，而是If语句。如果我正确理解逻辑，则可以按照以下方法重写代码。

Sub PullNames()

    Dim A As Range
    Dim B As Range
    Dim C As Range
    Dim A2 As Range
    Dim B2 As Range
    Dim C2 As Range
    Dim LastA As Long
    Dim LastB As Long
    Dim LastC As Long
    Dim LastA2 As Long
    Dim CheckName As String
    Dim CheckName2 As String
    Dim count As Long, count2 As Long
    Dim Name_ As String
    Dim Name2 As String

    LastA = Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Row
    LastB = Sheets("Sheet1").Cells(Rows.count, 2).End(xlUp).Row
    LastC = Sheets("Sheet1").Cells(Rows.count, 3).End(xlUp).Row
    count = 2

    Set A = Sheets("Sheet1").Range("A2:A" & LastA)
    Set B = Sheets("Sheet1").Range("B2:B" & LastB)
    Set C = Sheets("Sheet1").Range("C2:c" & LastC)
    Set A2 = Sheets("Sheet2").Range("A" & count)
    Set B2 = Sheets("Sheet2").Range("B" & count)
    Set C2 = Sheets("Sheet2").Range("C" & count)

    Sheets("Sheet2").Activate
    A2.Activate

    A.Copy Destination:=A2
    A2.RemoveDuplicates Columns:=1, Header:=xlNo
    A2.Columns.AutoFit

    Sheets("Sheet1").Activate

    LastA2 = Sheets("Sheet2").Cells(Rows.count, 1).End(xlUp).Row

    Do Until count > LastA
        CheckName = Sheets("Sheet1").Range("A" & count)
        Name_ = CheckName

            'creates a loop for the macro to go through the names on Sheet2
            'If count < LastA2 Then
            count2 = 2
            Do While count2 <= LastA2
                CheckName2 = Sheets("Sheet2").Range("A" & count2)
                Name2 = CheckName2
                    If Name_ = Name2 Then
                        'B2 = B.Value
                        Sheets("Sheet2").Range("B" & count2).Value = Sheets("Sheet1").Range("B" & count).Value
                    End If

                count2 = count2 + 1
            Loop
            'End If

    count = count + 1
    Loop


End Sub

如果有重复项（已删除），则此代码将拉出它遇到的最后一个值，您可能不希望这样做。例如，如果B是一个数字，则可能需要将这些数字加到B列中。

这就是我编写代码的方式。

Public Sub PullNames2()

    Dim rCell As Range
    Dim rFound As Range
    Dim rNames As Range

    'Define the range that contains the names
    'copy that range to sheet2 and remove the dupes
    Set rNames = Sheet1.Range("A2").CurrentRegion.Columns(1)
    rNames.Copy Sheet2.Range("A2")
    With Sheet2.Range("A2").CurrentRegion
        .RemoveDuplicates 1, xlNo
        .Columns.AutoFit
    End With

    'Loop through all the names
    For Each rCell In rNames.Cells
        'use the Find method to find the name on sheet2
        Set rFound = Nothing
        Set rFound = Sheet2.Columns(1).Find(rCell.Value, , xlValues, xlWhole)

        'If you found the name, add the value in B to whatever is already there
        If Not rFound Is Nothing Then
            rFound.Offset(0, 1).Value = rFound.Offset(0, 1).Value + rCell.Offset(0, 1).Value
        End If
    Next rCell

End Sub

一些注意事项：

我使用工作表的代号。这些是VBA知道的名称，而不是选项卡名称。您不必使用它们，这只是我的偏好。
如果您没有任何差距，那么CurrentRegion很好。如果它不适用于您的数据，则可以设置rNames，但是您想定义范围。您只需要对sheet2使用相同的方法。
您必须每次将rFound设置为Nothing，因为它会记住上一次发现的内容。这样，您可以检查Nothing-如果找不到，rFound就是它。

在互联网上对数据副本进行

始终测试代码。尤其是可以更改内容的代码。

在VBA中嵌套“执行至”和“用于”循环

1 个答案: