Excel VBA匹配2張紙上的數據。 需要幫助重復代碼

Question

我下面的代碼在名稱旁邊列出“白色”（表示武術白色腰帶）時，將其從工作表1中提取姓氏和名字並將其粘貼到工作表2中，並將其粘貼到“ x”行的標題下方。 對於下一個皮帶級別為“ Pro Yellow”，我需要幫助來重復此代碼。 名字和姓氏標題需要粘貼到第78行，然后將名字從79行向下粘貼。

Sub PastetoAdult()
Dim lr As Long, lr2 As Long, r As Long
Set Sh1 = ThisWorkbook.Worksheets("ADULT members to cut & past")
Set Sh2 = ThisWorkbook.Worksheets("ADULT Sign On Sheet")
Sh1.Select

Sh2.Cells(6, 5).Value = "LAST NAME"
Sh2.Cells(6, 6).Value = "FIRST NAME"**
lr = Sh1.Cells(Rows.Count, "B").End(xlUp).Row
x = 7
For r = 2 To lr
    If Range("I" & r).Value = "White" Then
        Sh2.Cells(x, 5).Value = Sh1.Cells(r, 2).Value
        Sh2.Cells(x, 6).Value = Sh1.Cells(r, 3).Value
        x = x + 1
    End If

Next r

Sh2.Select

End Sub

Answer 1

以下代碼將遍歷添加到數組中的每種皮帶顏色，並在每個標題組之間放置5條空行。

Option Explicit

Sub PastetoAdult()
Dim lr As Long, lr2 As Long, r As Long, x As Long
Dim iBelts As Integer
Dim sBeltColor() As String
Dim Sh1 As Worksheet, Sh2 As Worksheet

Set Sh1 = ThisWorkbook.Worksheets("ADULT members to cut & past")
Set Sh2 = ThisWorkbook.Worksheets("ADULT Sign On Sheet")
Sh1.Select

lr = Sh1.Cells(Rows.Count, "B").End(xlUp).Row
x = 5   'Start Row

'Load all belt colors into an array via splitting a comma delimited string
sBeltColor() = Split("White,Pro Yellow", ",")

For iBelts = 0 To UBound(sBeltColor)

    'Place belt color as header followed by 'Last Name' & 'First Name' 
    'on the next row with no gap between groups
    Sh2.Cells(x, 5).Value =sBeltColor(iBelts)
    x = x + 1
    Sh2.Cells(x, 5).Value = "LAST NAME"
    Sh2.Cells(x, 6).Value = "FIRST NAME"
    x = x + 1
    For r = 2 To lr
        If Range("I" & r).Value = sBeltColor(iBelts) Then
            Sh2.Cells(x, 5).Value = Sh1.Cells(r, 2).Value
            Sh2.Cells(x, 6).Value = Sh1.Cells(r, 3).Value
            x = x + 1
        End If
    Next r
Next iBelts
Sh2.Select

End Sub