Excel VBA che corrisponde i dati in 2 fogli. bisogno di aiuto per ripetere il codice

Il codice riportto di seguito tira i nomi dei cognomi dal foglio di lavoro 1 e li inserisce nel foglio di lavoro 2 quando è elencato accanto al loro nome "Bianco" (che significa cintura bianca di arti marziali) e li incolla sotto le intestazioni della row "x". Ho bisogno di aiuto per ripetere questo codice per il livello della cintura successivo "Pro Giallo". Le intestazioni nome e cognome devono essere incollate alla row 78 e quindi i nomi incollati dalla row 79 in giù.

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 

Il codice riportto di seguito verrà ripetuto attraverso each colore della cintura aggiunto all'arrays e posiziona 5 righe vuote tra ciascun gruppo di intestazione.

 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 arrays 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 Opzione esplicita 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 arrays 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