小白求助：分解工作表

wwww32323

想把表一根据列2分解成多个表，手工比较慢。谢谢大神 分表问题.rar (35.63 KB, 下载次数: 4)

2019-8-19 19:40 上传

点击文件名下载附件

wwww32323

朱荣兴 发表于 2019-8-19 23:36
函数公式解决不了你的问题，vba可以，也就是个拆分问题，可以到我的主题里去下载拆分工具

你的工具非常强大，但是我不是想保留列，而是想保留工作表，sheet2 3 也保留在独立生成的每个工作簿中，不过还是非常感谢

wwww32323

http://club.excelhome.net/forum. ... d=398041&page=1






Option Explicit
Sub addWK2()
Dim dic, temp, arr, tempWK, temp2
Dim rng As Range
Const BYSHNAME As String = "数据表" '可以修改根据哪一个工作表拆分工作簿
Application.ScreenUpdating = False
Set dic = CreateObject("scripting.dictionary") '字典
'下面一句代码：设置上面设置的工作表中的哪一列的内容拆分工作簿
Set rng = ThisWorkbook.Sheets(BYSHNAME).Range("b2:b" & ThisWorkbook.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row)
For Each temp In rng.Cells '这个for循环实现该列的不重复值的筛选
    If Not dic.exists(temp.Value) Then
        dic.Add temp.Value, ""
    End If
Next
arr = dic.keys '返回此列不重复值的数组

For Each temp In arr '这个For循环实现按照不重复数组的内容新建工作簿，并复制应有的内容
    ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "" & temp & ".xls" '以当前temp的值为新工作簿的名称，备份当前工作簿
   
   
   
    Set tempWK = Workbooks.Open(ThisWorkbook.Path & "" & temp & ".xls") '打开以temp的值为名称的工作簿
   
   
        
        tempWK.Sheets(BYSHNAME).Cells.Clear '清除该工作簿以BYSHNAME为名称的工作表的所有内容
   
    For Each temp2 In rng '这个for循环是比较源工作簿中拆分依据的工作表中，拆分依据的那一列与当前temp值是否相同，相同即复制相关内容
        If temp2 = temp Then
        '下面代码：temp2.Offset(0, 1 - rng.Column).Resize(1, 4).Copy是复制源工作表的从A-D列的内容
        '代码tempWK.Sheets(BYSHNAME).Cells(tempWK.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row + 1, 1)是获取tempWK工作簿以BYSHNAME为名称的工作表的最后列的下一行第一列的位置
            temp2.Offset(0, 1 - rng.Column).Resize(1, 4).Copy tempWK.Sheets(BYSHNAME).Cells(tempWK.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row + 1, 1)
            
        End If
    Next
    ThisWorkbook.Sheets(BYSHNAME).Range("1:1").Copy tempWK.Sheets(BYSHNAME).Range("1:1") '复制标题栏
    tempWK.Save
    tempWK.Close
Next
Application.ScreenUpdating = True
Set dic = Nothing
Set rng = Nothing
ThisWorkbook.Sheets(1).Select

   
   
End Sub