工作簿拆分问题（要求保留其它工作表）

Hoer

圆满解决问题，万分谢谢fdd~

[ 本帖最后由 Hoer 于 2009-2-17 10:55 编辑 ]

fdd

原帖由 Hoer 于 2009-2-17 10:20 发表
圆满解决问题，万分谢谢fdd~

Option Explicit
Sub addWK2()
    Dim dic, temp, arr, tempWK, temp2
    Dim rng As Range
    Dim strArea As String
    Const BYSHNAME As String = "数据表" '可以修改根据哪一个工作表拆分工作簿
   
    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的值为名称的工作簿
        strArea = "" '用于储存所有需要删除的行的地址字符串
        For Each temp2 In rng.Cells '这个for循环是比较源工作簿中拆分依据的工作表中，拆分依据的那一列与当前temp值是否相同，删除不相关内容
            If temp2 <> temp Then
                If strArea <> "" Then
                    strArea = strArea & ","
                End If
                strArea = strArea & tempWK.Sheets(BYSHNAME).Cells(temp2.Row, temp2.Column).EntireRow.Address
            End If
        Next
        tempWK.Sheets(BYSHNAME).Range(strArea).Delete
        tempWK.Save
        tempWK.Close
    Next
   
    Set dic = Nothing
    Set rng = Nothing
    ThisWorkbook.Sheets(1).Select
End Sub

[ 本帖最后由 fdd 于 2009-2-17 17:25 编辑 ]

xzcpv

你好幽谷专家
如果上个例子中的名称由甲乙丙改为，北京abc公司，北京市XXX公司，江苏HGF公司，河北XXX等等
想把他们拆分到以北京 江苏 等工作表中
这些工作表在拆分前都已经存在不删除，和数据表在一个工作薄中，改如何修改呢？
谢谢

garywang

的都是范德萨

qw7566

好好学习了

syaj2001

fdd 发表于 2009-2-17 10:13
链接的问题是您的函数或代码本身的问题。程序还不可能智能到去判断函数或代码内容并根据此内容去做相应 ...

你好，我有个问题，现在是除了“数据表”拆分，其他两个表都原封不动，那如果其他两个表也按照数据表某一列拆分，然后还是拆成一个工作簿里面，包含“数据表”“说明表”“备注表”呢（假设另外两张表也有数据表中的那一列)？