[已解决]帮忙看一下拆分工作簿的代码如何更正

zhong4314

请教大家，想把附件的工作表按批次拆分成多个工作簿，但失败了，请帮忙看看我的代码哪个位置如何更正，谢谢

   

最佳答案

月排行榜 / 总排行榜

cutecpu

2021-4-17 14:45

zhong4314 发表于 2021-4-17 11:15
代码如下：

Sub demo()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   Dim biaoti As Range, pihao As Range, rng As Range, mypath$
   Set biaoti = Range("A1:H1")
   For Each pihao In Range("H2", [H2].End(xlDown))
      Set rng = pihao.EntireRow
      If pihao.Value <> pihao(0, 1).Value Then
         If ActiveWorkbook.Name <> ThisWorkbook.Name Then ActiveWorkbook.Close 1
         Workbooks.Add.SaveAs ThisWorkbook.Path & "\" & pihao.Value & ".xlsx"
         biaoti.Copy [a1]
         rng.Copy [A2]
         Row = 2
      Else
         Row = Row + 1
         rng.Copy Range("a" & Row)
      End If
   Next
   ActiveWorkbook.Close 1
End Sub

祝順心，南無阿彌陀佛！

跳转到最佳答案楼层

zhong4314

代码如下：

cutecpu

zhong4314 发表于 2021-4-17 11:15
代码如下：

Sub demo()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   Dim biaoti As Range, pihao As Range, rng As Range, mypath$
   Set biaoti = Range("A1:H1")
   For Each pihao In Range("H2", [H2].End(xlDown))
      Set rng = pihao.EntireRow
      If pihao.Value <> pihao(0, 1).Value Then
         If ActiveWorkbook.Name <> ThisWorkbook.Name Then ActiveWorkbook.Close 1
         Workbooks.Add.SaveAs ThisWorkbook.Path & "\" & pihao.Value & ".xlsx"
         biaoti.Copy [a1]
         rng.Copy [A2]
         Row = 2
      Else
         Row = Row + 1
         rng.Copy Range("a" & Row)
      End If
   Next
   ActiveWorkbook.Close 1
End Sub

祝順心，南無阿彌陀佛！

zhong4314

cutecpu 发表于 2021-4-17 14:45
Sub demo()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False

收到，辛苦老师了

zhong4314

cutecpu 发表于 2021-4-17 14:45
Sub demo()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False

老师，这句代码中：
Workbooks.Add.SaveAs ThisWorkbook.Path & "\" & pihao.Value & ".xlsx"
  biaoti.Copy [a1]

[a1] 前面不用写workbooks(pihao.name). 吗？当新添加了工作簿后，excel不会默认biaoti所属的工作簿为新建的工作簿吗

cutecpu

zhong4314 发表于 2021-4-17 22:13
老师，这句代码中：
Workbooks.Add.SaveAs ThisWorkbook.Path & "\" & pihao.Value & ".xlsx"
  biaoti ...

1. [a1] 前面不用写workbooks(pihao.name). 吗？
答：不用喔，這時候的 [a1] 就是 新開工作簿 workbooks(pihao.name) 裡的喔

2. 当新添加了工作簿后，excel不会默认biaoti所属的工作簿为新建的工作簿吗
答：不會喔，因為 biaoti 是在 For Each pihao  ... 前就設好了喔，那時候還是原來工作簿的標題列喔！

祝順心，南無阿彌陀佛！

zhong4314

cutecpu 发表于 2021-4-17 22:31
1. [a1] 前面不用写workbooks(pihao.name). 吗？
答：不用喔，這時候的 [a1] 就是 新開工作簿 workbooks ...

哦哦，原来如此，完全明白了，这个很重要，谢谢老师