添加库引用

      Microsoft Scripting Runtime

定义变量

        dim dic as Dictionary

        set dic = CreateObject("scripting.dictionary")

Sub 统计林权证()
   On Error Resume Next
    Dim huZhu As String
    Dim yb As Worksheet
    Dim jg As Worksheet
    Set yb = ThisWorkbook.Sheets("沙坪到户数")
    Set jg = ThisWorkbook.Sheets("结果")   
    Dim startRow As Integer
    Dim hm As String 
    Dim dic2 As Dictionary
    Set dic2 = CreateObject("scripting.dictionary")  
    For startRow = 6 To 7412        
        If yb.Cells(startRow, "j") <> "" Then
            '写入前一条,判断集合个数                       
            If dic2.count > 0 Then              
               jg.Cells(count + 2, 1) = huZhu
               jg.Cells(count + 2, 2) = "'" & CStr(Join(dic2.Keys, ",")) '前面加上"'"确保前导0不被省略
               dic2.RemoveAll 
            End If
            huZhu = yb.Cells(startRow, "j")
            If Trim(yb.Cells(startRow, "h").Value) <> "" Then
                dic2.Add CStr(yb.Cells(startRow, "h").Value), ""  '添加至key
            End If
            Debug.Print "户主:" & huZhu            
        Else
            'Debug.Print CStr(Cells(startRow, "h").Value)
            If dic2.Exists(CStr(yb.Cells(startRow, "h"))) Then '确保不被重复写入，若存在则放弃            
            Else
             If Trim(yb.Cells(startRow, "h").Value) <> "" Then 
                 dic2.Add CStr(yb.Cells(startRow, "h").Value), ""
              End If
            End If                        
        End If                  
    Next startRow     
     jg.Cells(count + 2, 1) = huZhu
     jg.Cells(count + 2, 2) = CStr(Join(dic2.Keys, ",")) '将姓名与编号对应输出           
End Sub

Sub 写入结果()
    Dim wbName As String
    Dim dic As Dictionary
    Set dic = CreateObject("scripting.dictionary")       
     Dim yb As Worksheet
     Set yb = ThisWorkbook.Sheets("结果")
     Dim name As String
     For i = 2 To yb.UsedRange.Rows.count  '将上面得到的结果再构造为集合，方便查找，比数组，循环嵌套更高效
        name = yb.Cells(i, 1)
        If dic.Exists(name) Then ' 可能一个户主出现多次
           dic.Item(yb.Cells(i, 1).Value) = dic.Item(yb.Cells(i, 1).Value) & "," & yb.Cells(i, 2)
        Else            
           dic.Add yb.Cells(i, 1).Value, yb.Cells(i, 2).Value            
       End If
     Next i        
     Debug.Print dic.count '验证
     '开始写入数据
     sh.Cells(3, 14) = "测试"
     For j = 3 To 10
        sh.Cells(j, "N").Value = dic.Item(sh.Cells(j, "G").Value)
        Debug.Print sh.Cells(j, "G"), dic.Item(sh.Cells(j, "G").Value)
       ' Debug.Print dic.Item(sh.Cells(j, "G"))
     Next j                
End Sub