[已解决]按总表的表1表2表3A列拆分成文件

chensir

各位好，求助：
根据 按总表的表1表2表3A列的公司拆分成A、B、C三个文件，并且每个文件的表1表2表3都保留，具体见附件，谢谢。

最佳答案

月排行榜 / 总排行榜

cutecpu

2021-3-5 14:03

Sub demo()

   Application.DisplayAlerts = False

   dummy = ThisWorkbook.Name & ".dummy"
   ActiveWorkbook.SaveCopyAs dummy

   arr = [a1].CurrentRegion
   col = UBound(arr, 2)

   For i = 2 To UBound(arr)
      Path = ThisWorkbook.Path & "\" & arr(i, 1) & ".xlsx"
      Set wb = Workbooks.Open(dummy)
      For s = 1 To Sheets.Count
         With Sheets(s)
            .Range(.Cells(i, 1), .Cells(i, col)).Copy .Range("A2")
            .UsedRange.Offset(2).Clear
         End With
      Next
      wb.SaveAs Path, FileFormat:=xlOpenXMLWorkbook
      wb.Close
   Next

End Sub


祝順心，南無阿彌陀佛！

跳转到最佳答案楼层

cutecpu

Sub demo()

   Application.DisplayAlerts = False

   dummy = ThisWorkbook.Name & ".dummy"
   ActiveWorkbook.SaveCopyAs dummy

   arr = [a1].CurrentRegion
   col = UBound(arr, 2)

   For i = 2 To UBound(arr)
      Path = ThisWorkbook.Path & "\" & arr(i, 1) & ".xlsx"
      Set wb = Workbooks.Open(dummy)
      For s = 1 To Sheets.Count
         With Sheets(s)
            .Range(.Cells(i, 1), .Cells(i, col)).Copy .Range("A2")
            .UsedRange.Offset(2).Clear
         End With
      Next
      wb.SaveAs Path, FileFormat:=xlOpenXMLWorkbook
      wb.Close
   Next

End Sub


祝順心，南無阿彌陀佛！

chensir

cutecpu 发表于 2021-3-5 14:03
Sub demo()

   Application.DisplayAlerts = False

如果满足以下条件如何操作：
1、某公司在表1中存在；
2、某公司在表1、表2中存在；
3、某公司在表1、表2、表3中存在；
4、某公司在表2中存在；
5、某公司在表2、表3中存在；
6、某公司表3中存在
这6种情况表1、表2、表3文件表都保留，即使里面没有数据，请问如何操作，谢谢。
例如：第2种情况，A公司在表1、表2中存在，那么拆分的A文件里，表1、表2是A公司的信息，表3为空。
不知道说清楚了吗，谢谢。

cutecpu

chensir 发表于 2021-3-8 11:22
如果满足以下条件如何操作：
1、某公司在表1中存在；
2、某公司在表1、表2中存在；

Sub demo()

   Application.DisplayAlerts = False
   Application.ScreenUpdating = False

   dummy = ThisWorkbook.Path & "\" & ThisWorkbook.Name & ".dummy"
   ActiveWorkbook.SaveCopyAs dummy

   ReDim d(1 To 3)
   For i = 1 To 3
      Set d(i) = CreateObject("Scripting.Dictionary")
      arr = Sheets(i).[a1].CurrentRegion
      For r = 2 To UBound(arr)
         d(i)(arr(r, 1)) = r
      Next
   Next

   For i = 1 To 3
      keys = d(i).keys
      For Each Key In keys
         Set wb = Workbooks.Open(dummy)
         For s = 1 To 3
            With Sheets(s)
               If d(s).exists(Key) Then
                  r = d(s)(Key)
                  .Range(.Cells(r, 1), .Cells(r, 2)).Copy .Range("A2")
                  .UsedRange.Offset(2).Clear
                  d(s).Remove Key
               Else
                  .UsedRange.Offset(1).Clear
               End If
            End With
         Next
         Path = ThisWorkbook.Path & "\" & Key & ".xlsx"
         wb.SaveAs Path, FileFormat:=xlOpenXMLWorkbook
         wb.Close
      Next
   Next
End Sub

祝順心，南無阿彌陀佛！