MS-Excel - Макрос для копирования уникальных ячеек с одного листа на другой

Question

Я новичок в написании макросов в VBA.

Я работаю над автоматизацией процесса.

Это то, что мне нужно сделать

Пример данных
Лист1

Group_Name
  RootGrp1
  RootGrp2
  RootGrp3

Лист2

Group_Name - Member_Name
  RootGrp1 - Member_A
  RootGrp1 - Member_B
  RootGrp1 - Member_C
  RootGrp2 - Member_D
  RootGrp2 - Member_B
  RootGrp2 - Member_C
  RootGrp3 - Member_A
  RootGrp3 - Member_B
  RootGrp3 - Member_E
  Member_A - Member_F

Результат
Лист1-Modified

Group_Name
  RootGrp1
  RootGrp2
  RootGrp3
  Member_A
  Member_B
  Member_C
  Member_D
  Member_E
  Member_F

Процесс

1. Он анализирует Sheet1.
2. Для каждой существующей записи добавляются все соответствующие имена_символов из Sheet2 в Sheet1 (Позаботьтесь о том, чтобы игнорировать любое имя участника, которое уже было добавлено)
3. Повторяйте до тех пор, пока все записи в Sheet1 не будут обработаны. (Включая динамически добавленные)

Есть ли способ сделать это? Пожалуйста, помогите !!!

Ниже приведен код, который я придумал до сих пор. В настоящее время сталкиваются с некоторыми проблемами с методом FindNext.

Sub My_Function()


    Sheets(1).Activate
    Range("A2").Select
    Set Marker = Cells(ActiveCell.Row, ActiveCell.Column)


    Do Until IsEmpty(Marker)

        Query = Marker.Value
        With Sheets(2).Range("A1", "A20")
            Set Index = .Find(Query, LookIn:=xlValues)
            If Not Index Is Nothing Then
                firstAddress = Index.Address

                Do
                    Result = Index.Offset(0, 1)

                    With Sheets(1).Range("A1", Range("A65536").End(xlUp))
                        Set Lookup = .Find(Result, LookIn:=xlValues)
                        If Lookup Is Nothing Then
                            Worksheets(1).Range("A65536").End(xlUp).Offset(1, 0).Value = Result
                        End If
                    End With

                    Set Index = .FindNext(Index)
                Loop While Not Index Is Nothing And Index.Address <> firstAddress
            End If
        End With

        Set Marker = Marker.Offset(1, 0)
    Loop

End Sub

П.С. - Я знаю, что код написан не очень хорошо. Прошу прощения, так как это мой первый настоящий макрос VBA.

Answer 1

Проверьте это. Немного подправил свой код.

Sub fMain()
    Sheets(1).Activate
    Range("A2").Select
    Set Marker = Cells(ActiveCell.Row, ActiveCell.Column)
    Do Until IsEmpty(Marker)
        Query = Marker.Value
        With Sheets(2).Range("A2", "A20")
            Set Index = .Find(Query, LookIn:=xlValues)
            If Not Index Is Nothing Then
                firstAddress = Index.Address
                Do
                    Result = Index.Offset(0, 1)
                    fHelper Result
                    Set Index = .Find(What:=Query, After:=Index)
                Loop While Not Index Is Nothing And Index.Address <> firstAddress
            End If
        End With
        Set Marker = Marker.Offset(1, 0)
    Loop
End Sub

Sub fHelper(Result)
    With Sheets(1).Range("A2", Range("A65536").End(xlUp))
        Set Lookup = .Find(Result, LookIn:=xlValues)
        If Lookup Is Nothing Then
            Worksheets(1).Range("A65536").End(xlUp).Offset(1, 0).Value = Result
        End If
    End With
End Sub