|
发表于 2019-7-22 13:24
来自手机
|
显示全部楼层
本帖最后由 守护最爱的坤坤 于 2019-7-22 17:11 编辑
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 |
|