求助高手，用VBA新建工作表怎么按要求导入数据？

kingu

大家好，我对这个VBA实在是弄不太明白，而现在手头有点任务确实又需要用到这个，否则要浪费很多时间才行。我的具体的需要达到的效果就是：以某个工作表的内容为模板，批量新建多个工作表，而建几个工作表以另一个原始数据表里面的户数来定。表格名称以001开始，对应原始数据表里面的001户，以此类推。而新建工作表后，要在新建表里面的空表里面导入相对应的原始数据表里面的内容。比如001这个工作表，里面的内容有两个，上下对应村与村民小组的，姓名身份证这些是001这户的所有人的数据，只有后面的分享的股金不同。都是可以在原始数据表里面导入进来的。001表导入数据表里面的对应的001户的所有人，其他类推。
说明：附件内容第一个工作表是原始要导入的数据，第二个001表就是我新建的一个工作表，里面的内容按此导入。接下来就是002，003，004，------

守护最爱的坤坤

Public Sub test()
Application.ScreenUpdating = False '关闭屏幕更新
    With Worksheets("001")
        .Name = "模板表" '把001表改名为模板表，方便后面直接选择活动工作表进行数据输入
.Range("c6:c15,d6:f14,e15:f15,c17:c26,d17:f25,e26:f26").ClearContents '清除模板表指定区域的内容
        .Range("e6:e15,e17:e26").NumberFormat = "general" '设置模板表相应区域单元格格式为常规
        .Range("f6:f15,f17:f26").NumberFormat = "0.00"    '设置模板表相应区域单元格格式为“0.00”
    End With
  Dim arr, arr1 'arr1储存源数据表a列所有数据及第一个空单元格,arr储存源数据表除a列和标题外所有数据
    Dim arow As Long
    arow = Range("a65536").End(xlUp).Row
    ReDim arr1(3 To arow + 1)
    ReDim arr(3 To arow + 1, 2 To 7)
    Dim i As Long, m As Integer
    For i = 3 To arow + 1
        arr1(i) = Format(Worksheets("sheet1").Range("a" & i).Value, "000")
        For m = 2 To 7
            arr(i, m) = Worksheets("sheet1").Cells(i, m).Value
        Next m
    Next i
    Dim lastrow As Long 'lastrow存储每一户最后一位家庭成员所在单元格行号
    Dim renkou As Integer
    renkou = 1 'renkou储存每一户家庭人口数，每一户至少为1人
    Dim addrow As Integer 'addrow为添加行过程的循环变量
    Dim charuhang As Integer 'charuhang即插入行，记录插入的行数
    charuhang = 0 '初始化插入行
    Dim huzhu As Long  'huzhu储存每一户户主所在单元格行号
    Dim lie As Integer 'lie为户主那一行各个单元格列号
  Dim tianhang As Integer
    Dim tianlie As Integer 'tianruhang,tianrulie分别为需要填入数据的单元格所要填入的数据在源数据表中的行号和列号
    Dim arrs, arrx
    For lastrow = 3 To arow
        If arr1(lastrow) = arr1(lastrow + 1) Then
            renkou = renkou + 1
        Else'边建表边填数据
            Worksheets("模板表").Copy after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = arr1(lastrow)  '新建工作表并重命名
            If renkou > 1 Then '当人口大于1时，户主可能不在该户的第一个，通过循环把户主所在行数据与第一位家庭成员交换，方便后面输入数据
                For huzhu = lastrow - renkou + 1 To lastrow '通过循环得到huzhu即户主所在单元格行号
                    If arr(huzhu, 2) = arr(huzhu, 3) Then
                        For lie = 3 To 7
                            Dim s As Variant
                            s = arr(huzhu, lie)
                            arr(huzhu, lie) = arr(lastrow - renkou + 1, lie)
                            arr(lastrow - renkou + 1, lie) = s
                        Next lie
                    End If
                Next huzhu
            End If
            If renkou > 9 Then '判断单元格是否足够填入，不够则添加行至足够，因为有些家庭可能人口比较多
                For addrow = 1 To renkou - 9
                    ActiveSheet.Rows(13).Insert
                    ActiveSheet.Rows(24).Insert
                    charuhang = charuhang + 1
                Next addrow
            End If
            '准备工作完成，下面进行数据输入，脑壳疼,先把要填入的数据分别放到数组arrs和arrx里
            ReDim arrs(lastrow - renkou + 1 To lastrow, 3 To 6), arrx(lastrow - renkou + 1 To lastrow, 3 To 6)
                For tianhang = lastrow - renkou + 1 To lastrow
                    For tianlie = 3 To 6
                        arrx(tianhang, tianlie) = arr(tianhang, tianlie)
                        If tianlie = 6 Then
                            arrs(tianhang, tianlie) = arr(tianhang, 7)
                        Else
                            arrs(tianhang, tianlie) = arr(tianhang, tianlie)
                        End If
                    Next tianlie
                Next tianhang
            With ActiveSheet '现在开始填数据
                .Range("c6").Resize(renkou, 4).Value = arrs
                .Range("c" & 17 + charuhang).Resize(renkou, 4).Value = arrx
                .Range("c" & 15 + charuhang).Value = renkou
                .Range("c" & 26 + charuhang * 2).Value = renkou
                .Range("e" & 15 + charuhang).Value = WorksheetFunction.Sum(.Range("e6").Resize(renkou, 1).Value)
                .Range("e" & 26 + charuhang * 2).Value = WorksheetFunction.Sum(.Range("e" & 17 + charuhang).Resize(renkou, 1).Value)
                .Range("f" & 15 + charuhang).Value = WorksheetFunction.Sum(.Range("f6").Resize(renkou, 1).Value)
                .Range("f" & 26 + charuhang * 2).Value = WorksheetFunction.Sum(.Range("f" & 17 + charuhang).Resize(renkou, 1).Value)
            End With
            Erase arrs
            Erase arrx
            charuhang = 0
            renkou = 1 'renkou要储存下一户人口数，因此应重新赋值为1
        End If
         Next lastrow
    Application.ScreenUpdating = True
End Sub

守护最爱的坤坤

你给的模板有问题，户主姓名应该出现在家庭成员姓名中

守护最爱的坤坤

代码我给你写好了，还在审核中

kingu

守护最爱的坤坤 发表于 2019-7-22 13:24
Public Sub test()
Application.ScreenUpdating = False '关闭屏幕更新
    With Worksheets("001")

谢谢你，你的代码我放到里面执行了，可以达到目的，不过有一个小问题就是，我的模板其实是以里面的000为模板，并不是001为模板，001是建立新表达到的效果，里面的D4单元格，股权证书编号按你这个执行后全部都是001里面的050406001这个编号，这个编号是随着户编号变化的，也就是002工作表这个编号也要变为050406002，直到最后一个。不知道这个怎么做。谢谢 另外我还想问一下简单的操作，也就是说所有的工作表都建立好了，单独从数据表里面导入数据，也就是导入每户人员和D4单元格的编号随着变这个又怎么操作？按数据表里面的户编号001直到末的，一个一个对应的单独的导入数据。