Вложенные циклы «До» и «Для» в VBA - PullRequest
Новая
       26

Вложенные циклы «До» и «Для» в VBA

0 голосов
/ 29 августа 2018

Я пытаюсь создать макрос, который переносит данные в столбце B из Sheet1 в Sheet2, если имена в столбце A Sheet1 соответствуют именам в столбце A в 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

1 Ответ

0 голосов
/ 29 августа 2018

У вас есть только один цикл. Место, где начинается ваш комментарий «создать цикл» - это не цикл, это оператор 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, если он не может найти то, что ищет.

Всегда проверяйте код из Интернета на копии ваших данных. Особенно код, который меняет вещи.

...