请教 如何将一个表里两sheet中的数据按相同关键词拆成独立表格

sl8831

请教 将一个表里两sheet中的数据按相同关键词拆成独立表格

将表按地区筛选 只筛选 河南郑州 河南洛阳 河南新乡 福建福州  福建厦门  福建泉州 安徽合肥 以上七个条件的
注意此excel有两个sheet 都要筛选 并将同地区的保存在同一个excel中 同时保持数据仍在原来所在的sheet  sheet名称不变（需重命名 与所拆分表sheet名称对应上）
分别保存成独立的excel 并以地址名称命名 保存在桌面

若表中无对应数据的就不用保存了 只有一个sheet中有数据的保存 同时另一个sheet不重命名（保持原始名称sheet1 sheet2.。。）
不是拆分后保存在其他sheet中

谢谢 高手帮忙

sl8831

请教 如何将一个表里两sheet中的数据按相同关键词拆成独立表格

sl8831

请高手帮忙

zhaogang1960

回复 10楼 zhaogang1960 的帖子
我本来是想 在菜单栏里能加一个按钮 一点就运行这个宏 把这个宏用个人工作薄保存 每次打开一个新表一点就能筛好

烦请高手再看一下这个帖子
http://club.excelhome.net/thread-671929-1-1.html

Sub Macro1()
    Dim cnn As Object, rs As Object, wb As Workbook, wb1 As Workbook
    Dim SQL$, arr, i%, desk$, Filename, sh As Worksheet
    arr = Array("河南郑州", "河南洛阳", "河南新乡", "福建福州", "福建厦门", "福建泉州", "安徽合肥")
    Filename = Application.GetOpenFilename(FileFilter:="Excel 工作簿文件 (*.xls),*.xls", Title:="请选择文件")
    If TypeName(Filename) = "Boolean" Then Exit Sub
    If Val(Right(Application.OperatingSystem, 4)) >= 6 Then
        desk = Environ("USERPROFILE") & "\Desktop\"
    Else
        desk = Environ("USERPROFILE") & "\桌面\"
    End If
    Set cnn = CreateObject("ADODB.Connection")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set wb = Workbooks.Open(Filename)
    cnn.Open "provider=Microsoft.jet.OLEDB.4.0;extended properties=excel 8.0;data source=" & Filename
    For i = 0 To UBound(arr)
        wb.SaveCopyAs desk & arr(i) & ".xls"
        Set wb1 = Workbooks.Open(desk & arr(i) & ".xls")
        For Each sh In wb1.Sheets
            SQL = "Select * From [" & sh.Name & "$] Where 地区='" & arr(i) & "'"
            Set rs = CreateObject("ADODB.Recordset")
            rs.Open SQL, cnn, 1, 3
            sh.[a1].CurrentRegion.Offset(1 + rs.RecordCount).Clear
            sh.[a2].CopyFromRecordset rs
        Next
        wb1.Close True
    Next
    wb.Close False
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "ok"
End Sub

sl8831

高手 太感谢了  对于这个代码还有三个请求  
一：能否让筛好的表打开后显示在表头位置，现在一打开是在最下面 还要自己往上拉。同时表下面有部分空白表格自己增加了边框 能否完善一下。
二：能否让没有数据的sheet不显示 删除掉 只保留有数据的sheet（如：只有sheet1有此地区数据sheet2没有 那么就不要sheet2。若只有sheet2有此地区数据sheet1没有 那么就不要sheet1 。若都有数据那就都要 若一个地区两个sheet中都没数据就不用创建excel表）
三：能否在打开文件时让后缀为 .xls和.xlsx都显示出来
不知道可否实现 不过现在这样已经没满意了 再次感谢高人的帮忙！

再烦请您看一眼 http://club.excelhome.net/thread-671530-1-1.html 这个
您第二次给我的代码 筛出来表头的样式改变了，可否再修改一下。 还有为什么将代码保存在个人工作薄中再加到快速访问工作栏后 就无法正常运行了？我是希望增加一个菜单或按钮 实现一键筛表 谢谢！

[ 本帖最后由 sl8831 于 2011-1-14 10:19 编辑 ]

sl8831

劳驾高手 再帮忙看看~~
高手 太感谢了  对于这个代码还有三个请求  
一：能否让筛好的表打开后显示在表头位置，现在一打开是在最下面 还要自己往上拉。同时表下面有部分空白表格自己增加了边框 能否完善一下。
二：能否让没有数据的sheet不显示 删除掉 只保留有数据的sheet（如：只有sheet1有此地区数据sheet2没有 那么就不要sheet2。若只有sheet2有此地区数据sheet1没有 那么就不要sheet1 。若都有数据那就都要 若一个地区两个sheet中都没数据就不用创建excel表）
三：能否在打开文件时让后缀为 .xls和.xlsx都显示出来
不知道可否实现 不过现在这样已经没满意了 再次感谢高人的帮忙！

再烦请您看一眼 http://club.excelhome.net/thread-671530-1-1.html 这个
您第二次给我的代码 筛出来表头的样式改变了，可否再修改一下。 还有为什么将代码保存在个人工作薄中再加到快速访问工作栏后 就无法正常运行了？我是希望增加一个菜单或按钮 实现一键筛表 谢谢！

zhaogang1960

原帖由 sl8831 于 2011-1-14 10:33 发表
劳驾高手 再帮忙看看~~
高手 太感谢了  对于这个代码还有三个请求  
一：能否让筛好的表打开后显示在表头位置，现在一打开是在最下面 还要自己往上拉。同时表下面有部分空白表格自己增加了边框 能否完善一下。
二 ...

Sub Macro1()
    Dim cnn As Object, rs As Object, wb As Workbook, wb1 As Workbook
    Dim SQL$, arr, i%, desk$, Filename, sh As Worksheet, d As Object, av%, s$
    av = Application.Version
    If av <= 11 Then
        Filename = Application.GetOpenFilename(FileFilter:="Excel 工作簿文件 (*.xls),*.xls", Title:="请选择文件")
        s = ".xls"
    Else
        Filename = Application.GetOpenFilename(FileFilter:="Excel 工作簿文件 (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="请选择文件")
        s = ".xlsx"
    End If
    If TypeName(Filename) = "Boolean" Then Exit Sub
    If Filename = ThisWorkbook.FullName Then
        MsgBox "不能选择本文件！请重新选择"
        Exit Sub
    End If
    arr = Array("河南郑州", "河南洛阳", "河南新乡", "福建福州", "福建厦门", "福建泉州", "安徽合肥")
    Set d = CreateObject("scripting.dictionary")
    If Val(Right(Application.OperatingSystem, 4)) >= 6 Then
        desk = Environ("USERPROFILE") & "\Desktop\"
    Else
        desk = Environ("USERPROFILE") & "\桌面\"
    End If
    Set cnn = CreateObject("ADODB.Connection")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set wb = Workbooks.Open(Filename)
    If av <= 11 Then
        cnn.Open "provider=Microsoft.Jet.OLEDB.4.0;extended properties=excel 8.0;data source=" & Filename
    Else
        cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Filename
    End If
    For Each sh In wb.Sheets
        If Len(SQL) Then SQL = SQL & " union all "
        SQL = SQL & "Select distinct 地区 From [" & sh.Name & "$]"
    Next
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open SQL, cnn, 1, 3
    For i = 1 To rs.RecordCount
        d(rs.Fields(0).Value) = ""
        rs.MoveNext
    Next
    For i = 0 To UBound(arr)
        If d.Exists(arr(i)) Then
            wb.SaveCopyAs desk & arr(i) & s
            Set wb1 = Workbooks.Open(desk & arr(i) & s)
            For Each sh In wb1.Sheets
                SQL = "Select * From [" & sh.Name & "$] Where 地区='" & arr(i) & "'"
                Set rs = CreateObject("ADODB.Recordset")
                rs.Open SQL, cnn, 1, 3
                If rs.RecordCount > 0 Then
                    With sh
                        .Activate
                        .[a1].Select
                        lr = .[a1].CurrentRegion.Rows.Count
                        .[a1].CurrentRegion.Offset(1 + rs.RecordCount).Clear
                        .[a2].CopyFromRecordset rs
                    End With
                    ActiveWindow.SmallScroll Down:=lr * (-1)
                Else
                    sh.Delete
                End If
            Next
            wb1.Close True
        End If
    Next
    wb.Close False
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "ok"
End Sub

zhaogang1960

附件：
2003.rar (31.63 KB, 下载次数: 20)

2011-1-14 16:20 上传

点击文件名下载附件

20072010.rar (95.2 KB, 下载次数: 20)

2011-1-14 16:20 上传

点击文件名下载附件

sl8831

谢谢这位老师 太感谢了 对这个代码还有最后一个请求 之前忘了说了 能在保存的时候 以拼音的形式保存么
如：河南郑州 保存成 zhengzhou  河南洛阳 保存成 luoyang 。。。。这样不行的话 保存成 henanzhengzhou  henanluoyang 这样也可行
再次感谢！！

sl8831

谢谢这位老师 太感谢了 对这个代码还有最后一个请求 之前忘了说了 能在保存的时候 以拼音的形式保存么
如：河南郑州 保存成 zhengzhou  河南洛阳 保存成 luoyang 。。。。这样不行的话 保存成 henanzhengzhou  henanluoyang 这样也可行
再次感谢！！