如何根据某列出现过的值建工作表，并且出现几次就复制几次模板单据，将对应信息填...

kisooo

上传的附件中有写了一点的程序，还请各位老师帮忙完善，多谢！

目前我已经解决的部分：
汇总表H列有几个单位就新建几个sheet，并且以H列的值命名sheet；
将明细表模板（在sheet1）复制到各个明细表。

未解决部分：
汇总表H列单位出现几次就在对应明细表复制几遍模板，每次复制隔三行；
汇总表的黄色/橙色信息分别复制到对应明细表的黄色/橙色信息。

附件里有一个“手动完成效果”，如果我没说清楚可以参考，多谢了！

shenjianrong163

1. Sub 删除表()
   
2.     Application.DisplayAlerts = False
   
3.     If Worksheets.Count >= 4 Then
   
4.         For i = Worksheets.Count To 4 Step -1
   
5.             Worksheets(i).Delete
   
6.         Next
   
7.     End If
   
8.     Application.DisplayAlerts = True
   
9. End Sub
   
10. 
    
11. Sub 按单位建表()
    
12.     Dim i, j, r,arr
    
13.     Call 删除表
    
14.     With Sheets("汇总表")
    
15.         r = .Cells(.Rows.Count, 8).End(xlUp).Row
    
16.         arr = .Range("B3:H" & r)
    
17.     End With
    
18.    
    
19.     For i = 1 To UBound(arr)
    
20.         If TypeName(Application.Evaluate(arr(i, 7) & "!A1")) = "Error" Then
    
21.             Sheets("模板").Copy after:=Sheets(Sheets.Count)
    
22.             Sheets(Sheets.Count).Name = arr(i, 7)
    
23.             With Sheets(arr(i, 7))
    
24.                 j = .Cells(.Rows.Count, 2).End(xlUp).Row
    
25.                 .Range("D" & j - 5) = arr(i, 1)
    
26.                 .Range("D" & j - 4) = arr(i, 2)
    
27.                 .Range("D" & j - 3) = arr(i, 3)
    
28.                 .Range("C" & j - 2) = arr(i, 4)
    
29.                 .Range("C" & j - 1) = arr(i, 5)
    
30.             End With
    
31.         Else
    
32.             Sheets("模板").Rows("1:11").Copy Sheets(arr(i, 7)).Rows(Sheets(arr(i, 7)).Cells(Rows.Count, 2).End(xlUp).Row + 6)
    
33.             With Sheets(arr(i, 7))
    
34.                 j = .Cells(.Rows.Count, 2).End(xlUp).Row
    
35.                 .Range("D" & j - 5) = arr(i, 1)
    
36.                 .Range("D" & j - 4) = arr(i, 2)
    
37.                 .Range("D" & j - 3) = arr(i, 3)
    
38.                 .Range("C" & j - 2) = arr(i, 4)
    
39.                 .Range("C" & j - 1) = arr(i, 5)
    
40.             End With
    
41.         End If
    
42.     Next
    
43. End Sub
    

复制代码

shenjianrong163

请参考附件：



汇款信息单-待完成.rar (20.94 KB, 下载次数: 8)

2020-3-18 07:37 上传

点击文件名下载附件
1

kisooo

shenjianrong163 发表于 2020-3-18 07:33

太感谢您了！就是我想要的效果！这么早就来解答问题，感谢感谢感谢