Excel VBA matching data across 2 sheets. need help repeating the code -

my code below pulls first , last names worksheet 1 , pastes them worksheet 2 when "white" (meaning martial arts white belt) listed next name , pastes them below headings @ row "x". need repeat code next belt level being "pro yellow". first , last name headings need pasted @ row 78 , names pasted row 79 down.

sub pastetoadult() dim lr long, lr2 long, r long set sh1 = thisworkbook.worksheets("adult members 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 r = 2 lr     if range("i" & r).value = "white"         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 

the following code iterate through each belt color added array , place 5 blank lines between each header group.

option explicit  sub pastetoadult() dim lr long, lr2 long, r long, x long dim ibelts integer dim sbeltcolor() string dim sh1 worksheet, sh2 worksheet  set sh1 = thisworkbook.worksheets("adult members 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 belt colors array via splitting comma delimited string sbeltcolor() = split("white,pro yellow", ",")  ibelts = 0 ubound(sbeltcolor)      'place belt color header followed 'last name' & 'first name'      'on next row 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     r = 2 lr         if range("i" & r).value = sbeltcolor(ibelts)             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