查找多条匹配记录到新表格，如模板

石家庄星图

求大神哥哥帮忙，如何根据原表，将原表数据查找填充到家庭成员表中，

3190496160

原表数据查找填充到家庭成员表中，
1.哪么文件是家庭成员表？
2、自然幢号  和宗地号 如何对应？？？

石家庄星图

3190496160 发表于 2021-4-12 22:25
原表数据查找填充到家庭成员表中，
1.哪么文件是家庭成员表？
2、自然幢号  和宗地号 如何对应？？？

新表是家庭成员表，自然幢号就是宗地号+F0001-F000X，每一个撞号（f000x）需对应填写一组家庭成员

3190496160

Sub 家庭成员表()
Application.ScreenUpdating = False
Dim d As Object
Set d = CreateObject("scripting.dictionary")
ar = Sheet1.[a1].CurrentRegion
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        d(Trim(ar(i, 1))) = ""
    End If
Next i
ReDim br(1 To UBound(ar), 1 To 10)
For Each k In d.keys
    xh = xh + 1
    For i = 2 To UBound(ar)
        If Trim(ar(i, 1)) = k Then
            n = n + 1
            br(n, 1) = k & "F" & Format(xh, "0000")
            For j = 1 To UBound(ar, 2)
                br(n, j + 1) = ar(i, j)
            Next j
        End If
    Next i
Next k
Set wb = Workbooks.Open(ThisWorkbook.Path & "\模板.xlsx")
With wb.Worksheets(1)
    .[a2].Resize(n, UBound(br, 2)) = br
End With
wb.SaveAs Filename:=ThisWorkbook.Path & "\家庭成员表.xlsx"
wb.Close
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

原表.rar (180.49 KB, 下载次数: 15)

2021-4-13 09:14 上传

点击文件名下载附件

3190496160

不是很清楚你的需求，代码仅供参考
先对模板工作表做相应的格式设置，然后运行代码

石家庄星图

3190496160 发表于 2021-4-13 09:15
不是很清楚你的需求，代码仅供参考
先对模板工作表做相应的格式设置，然后运行代码

谢谢您  我试试

石家庄星图

石家庄星图 发表于 2021-4-13 10:16
谢谢您  我试试

很接近了 就是没有填充正确，还有就是每个号没有分条应该是一个撞号对应一组家庭成员

mxl800

这个问题需要插入行，所以单纯的用公式肯定不能完成，必须用VBA。试着写了一下：
Sub main()
    Dim 宗地号 As String
    Dim 自然幢数 As Long
    Dim tempRange As Range
    Dim 自然幢号 As Range
    Dim i As Long, j As Long, k As Long
    Dim 每户人数 As Long
    Dim 原表宗地号 As Range
    Dim 原表 As Worksheet, 新表 As Worksheet
    Dim 户主 As Range
   
    Set 原表 = Application.Workbooks("原表.xlsx").Worksheets("Sheet2")
    Set 原表宗地号 = 原表.Range("A2:A" & 原表.Cells(Rows.Count, 1).End(xlUp).Row)
    Set 新表 = Application.Workbooks("新表.xlsx").Worksheets("自然幢")
    自然幢数 = 新表.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 自然幢数 To 2 Step -1
        宗地号 = Left(新表.Cells(i, 1), Len(新表.Cells(i, 1)) - 5)
        Set 自然幢号 = 新表.Range("A2:A" & i)
        每户人数 = Application.WorksheetFunction.CountIf(原表宗地号, 宗地号)
        If Not 每户人数 = 0 Then
            Set 户主 = 原表.Cells(Application.WorksheetFunction.Match(宗地号, 原表宗地号, 0) + 1, 1)
            For k = 2 To 10
                新表.Cells(i, k) = 户主.Offset(0, k - 2)
            Next k
            For j = 1 To 每户人数 - 1
                新表.Rows(i + 1).Insert
                新表.Cells(i + 1, 1) = 新表.Cells(i, 1)
                For k = 2 To 10
                    新表.Cells(i + 1, k) = 户主.Offset(j, k - 2)
                Next k
            Next j
        End If
    Next i
End Sub

运行了一下，发现你的新表里有几条原表中没有对应宗地号的自然幢号。另外就是表头自己加吧，不是很多，就不写代码了。另外就是要保证在运行程序之前新表里的“自然幢号”没有重复的，所以运行程序之前要把重复的“自然幢号”删除，这个用数据功能区的删除重复数据即可。

说明：把这个程序复制到一个“启用宏的工作表”，然后把原表和新表都打开，运行程序就可以了。