批量复制工作表

shishui

批量复制工作表.rar (33.08 KB, 下载次数: 13)

2020-3-8 16:05 上传

点击文件名下载附件

学过一段VBA，但是不是经常用，这个问题遇到卡了，求助大神相助！！！

zzj198237

word 邮件合并

opel-wong

如果没有重复的数据，就加入数组，循环，复制工作表，填入数据，.....

如果有重复的数据，就加入字典，循环key，，，复制工作表，填入数据，......

思路挺简单，就是对应关系太多，需要点时间，有空给你写下吧，

shenjianrong163

1. Sub test()
   
2.     Dim i, r, arr
   
3.     Application.ScreenUpdating = False
   
4.     With Sheets("目录")
   
5.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.         arr = .Range("A3:U" & r)
   
7.     End With
   
8.     For i = 1 To UBound(arr)
   
9.         Sheets("模板").Copy after:=Sheets(Sheets.Count)
   
10.         Sheets(Sheets.Count).Name = arr(i, 6)
    
11.         Sheets(Sheets.Count).Activate
    
12.         [C2] = arr(i, 1)
    
13.         [E2] = arr(i, 2)
    
14.         [C3] = arr(i, 3)
    
15.         [E3] = arr(i, 4)
    
16.         [C4] = arr(i, 5)
    
17.         [C5] = arr(i, 6)
    
18.         [E5] = arr(i, 7)
    
19.         [G5] = arr(i, 8)
    
20.         [C6] = arr(i, 9)
    
21.         [E6] = arr(i, 10)
    
22.         [C7] = arr(i, 11)
    
23.         [E7] = arr(i, 12)
    
24.         [C8] = arr(i, 13)
    
25.         [E8] = arr(i, 14)
    
26.         [G8] = arr(i, 15)
    
27.         [C9] = arr(i, 16)
    
28.         [E9] = arr(i, 17)
    
29.         [G9] = arr(i, 18)
    
30.         [C10] = arr(i, 19)
    
31.         [C11] = arr(i, 20)
    
32.         [C12] = arr(i, 21)
    
33.     Next
    
34.     Application.ScreenUpdating = True
    
35. End Sub
    

复制代码

shenjianrong163

请参考附件：


批量复制工作表.rar (25.16 KB, 下载次数: 29)

2020-3-8 17:00 上传

点击文件名下载附件
1

鄂龙蒙

1. Sub test()
   
2.     Dim i, r, arr, sa
   
3.     Application.ScreenUpdating = False
   
4.     With Sheets("目录")
   
5.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
6.         arr = .Range("A3:U" & r)
   
7.     End With
   
8.     sa = Array("C2", "E2", "C3", "E3", "C4", "C5", "E5", "G5", "C6", "E6", _
   
9.             "C7", "E7", "C8", "E8", "G8", "C9", "E9", "G9", "C10", "C11", "C12")
   
10.     For i = 1 To UBound(arr)
    
11.         Sheets("模板").Copy after:=Sheets(Sheets.Count)
    
12.         Sheets(Sheets.Count).Name = arr(i, 6)
    
13.         Sheets(Sheets.Count).Activate
    
14.         For j = 0 To 20
    
15.             Range(sa(j)) = arr(i, j + 1)
    
16.         Next
    
17.     Next
    
18.     Application.ScreenUpdating = True
    
19. End Sub

复制代码

ghost6car

word的邮件合并，好用到停不下来。

shishui

鄂龙蒙 发表于 2020-3-8 19:33

果然是大神级，巨谢！！！！

shishui

shenjianrong163 发表于 2020-3-8 16:59

果然是大神级，巨谢！！！！

renkangjizhen

楼上的几位都是大神级别！受教了！