[已解决]描述如下

心正意诚身修 · 发表于 2015-7-23 13:11

將模版自動復制一個出來.然後依數據源中的第一條記錄,其中十個空填入在復制出來的工作表中,並將復制出來的工作表命名為第一條記錄的法人名稱.保存.復制到一個.同樣的操作.全部復制出來之後.結束.保存.謝謝好心的大神援手.感謝.

最佳答案

月排行榜 / 总排行榜

gufengaoyue

2015-7-23 16:41

本帖最后由 gufengaoyue 于 2015-7-23 17:10 编辑

试试看吧。2000多个表，我怕卡死，只试到100个表，你自己试试。
2000多个表放在同一个文件里，恐怕很难受...

Sub xx()
On Error Resume Next
Application.ScreenUpdating = False
Dim arr
arr = Sheets("數據源").UsedRange
For a = 3 To UBound(arr)
If Trim(arr(a, 4)) <> "" Then
Sheets("樣板").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = Replace(arr(a, 3), "?", "")
[d6] = arr(a, 3) 'c
[d7] = arr(a, 4) 'd
[h6] = arr(a, 2) 'b
[h7] = arr(a, 6) 'f
[d9] = arr(a, 8) 'h
[h9] = arr(a, 10) 'j
[d10] = arr(a, 14) 'n
[d11] = arr(a, 16) 'p
[h10] = arr(a, 15) 'o
[h11] = arr(a, 22) 'v
End If
Next
Application.ScreenUpdating = True
MsgBox "分表完成！", vbInformation
End Sub

复制代码

跳转到最佳答案楼层

gufengaoyue · 发表于 2015-7-23 14:36

1, 一个法人一个文件？还是在这个文件多增加工作表？
2,同一法人多个企业，要怎么弄？

看起来好像是宜昌的工商还是税务啊。

心正意诚身修 · 发表于 2015-7-23 14:51

gufengaoyue 发表于 2015-7-23 14:36
1, 一个法人一个文件？还是在这个文件多增加工作表？
2,同一法人多个企业，要怎么弄？

感謝大俠抽時間幫我看下.是的.一條記錄,一個表.一共兩千多條記錄,湖北宜昌的.

心正意诚身修 · 发表于 2015-7-23 15:55

繼續等待各位大俠出手相助

gufengaoyue · 发表于 2015-7-23 16:05

心正意诚身修发表于 2015-7-23 14:51
感謝大俠抽時間幫我看下.是的.一條記錄,一個表.一共兩千多條記錄,湖北宜昌的.

同一个法人，多个企业，以法人 1\2\3\4...来?

心正意诚身修 · 发表于 2015-7-23 16:20

gufengaoyue 发表于 2015-7-23 16:05
同一个法人，多个企业，以法人 1\2\3\4...来?

以納稅人名稱為准吧..一個納稅人名稱一個表格.

gufengaoyue · 发表于 2015-7-23 16:41

这个最佳答案由 gufengaoyue 给出，感谢 gufengaoyue 的回答。

单击隐藏图章

本帖最后由 gufengaoyue 于 2015-7-23 17:10 编辑

试试看吧。2000多个表，我怕卡死，只试到100个表，你自己试试。
2000多个表放在同一个文件里，恐怕很难受...

Sub xx()
On Error Resume Next
Application.ScreenUpdating = False
Dim arr
arr = Sheets("數據源").UsedRange
For a = 3 To UBound(arr)
If Trim(arr(a, 4)) <> "" Then
Sheets("樣板").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = Replace(arr(a, 3), "?", "")
[d6] = arr(a, 3) 'c
[d7] = arr(a, 4) 'd
[h6] = arr(a, 2) 'b
[h7] = arr(a, 6) 'f
[d9] = arr(a, 8) 'h
[h9] = arr(a, 10) 'j
[d10] = arr(a, 14) 'n
[d11] = arr(a, 16) 'p
[h10] = arr(a, 15) 'o
[h11] = arr(a, 22) 'v
End If
Next
Application.ScreenUpdating = True
MsgBox "分表完成！", vbInformation
End Sub

复制代码

dachairen · 发表于 2015-7-23 16:54

Sub 批量复制()
Dim arr, x&
arr = Sheets("數據源").[a1].CurrentRegion
Sheets("樣板").Copy
With ActiveSheet
      For x = 3 To UBound(arr)
         .[D6:D7] = Application.Transpose(Array(arr(x, 3), arr(x, 4)))
         .[D9:D11] = Application.Transpose(Array(arr(x, 8), arr(x, 14), arr(x, 16)))
         .[H6:H7] = Application.Transpose(Array(arr(x, 2), arr(x, 6)))
         .[H9:H11] = Application.Transpose(Array(arr(x, 10), arr(x, 15), arr(x, 22)))
         .Name = arr(x, 3)
         ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & arr(x, 3) & ".xls"
      Next
End With
ActiveWorkbook.Close False
End Sub

爱疯 · 发表于 2015-7-23 17:04

Sub test1()
Dim A, sh, i%, p$, f$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sh = Sheets(1)
p = ThisWorkbook.Path & "\Files\"
A = Sheets(2).Range("a1").CurrentRegion

For i = 3 To 5 'UBound(A)
      f = Replace(A(i, 3), "?", "")
      sh.Copy
      With ActiveWorkbook
         With .Sheets(1)
            .[d6] = A(i, 3)
            .[h6] = A(i, 2)
            .[d7] = A(i, 4)
            .[h7] = A(i, 6)
            .[d9] = A(i, 8)
            .[h9] = A(i, 10)
            .[d10] = A(i, 14)
            .[d11] = A(i, 16)
            .[h10] = A(i, 15)
            .[h11] = A(i, 22)
         End With
         .SaveAs p & f
         .Close
      End With
Next i
MsgBox "ok"
End Sub

新建文件夹.rar (224.66 KB, 下载次数: 11)

心正意诚身修 · 发表于 2015-7-23 17:09

gufengaoyue 发表于 2015-7-23 16:41
试试看吧。2000多个表，我怕卡死，只试到100个表，你自己试试。
2000多个表放在同一个文件里，恐怕很难受. ...

非常感謝.完全是我需要的.不過.我還是需要復制兩千多個表,至於電腦運行的事.讓他自己操心去,只要能實現他想要的效果就好.

		自动登录	找回密码
密码			注册

[已解决]描述如下

点评

评分

评分