[求助]一个文件里的3个表的另类拆分!

yijiboo

OiRnMLk3.rar (27.65 KB, 下载次数: 6)

2007-12-10 20:52 上传

点击文件名下载附件
[求助]一个文件里的3个表的另类拆分!

将 汇总.xls文件 拆分成;

地质工程组.xls   工区领导.xls   经营组.xls 这3个文件和它们里面的所有数据,就是想要的结果!

yijiboo

很有难度吧?有什么思路没有啊?

northwolves

1 提取不重复分类名称

2 另存XLS文件

3 遍历全部表，删除B列非该组数据整行，删除B列

4 保存文件，处理下一个分类名称

录制宏看看

yijiboo

期望

northwolves

  整个出来!...

彭希仁

如果使用常用工具2.5版将是非常容易解决这类问题

第一步:使用合并工具并多工作表合并成一个工作表.

第二步:使用拆分工具拆分成工作薄.

自已慢慢试吧.

BobPan

完全根据你的“汇总”表写的代码，此代码会分拆数据后保存在“汇总”表的目录下

Sub SplitBook()

Dim wb(2) As Workbook
Dim Index As Byte, bytIdx(1) As Byte, bytCnt(1) As Byte, Criteria(2) As String, strName As String

Application.ScreenUpdating = False

Set wb(0) = Workbooks.Add
Set wb(1) = Workbooks.Add
Set wb(2) = Workbooks.Add

bytCnt(0) = ThisWorkbook.Sheets.Count
bytCnt(1) = wb(0).Sheets.Count

If bytCnt(1) < 3 Then
    bytCnt(1) = bytCnt(0) - wb(0).Sheets.Count
    wb(0).Sheets.Add Count:=bytCnt(1)
    wb(1).Sheets.Add Count:=bytCnt(1)
    wb(2).Sheets.Add Count:=bytCnt(1)
End If

Criteria(0) = "地质工程组"
Criteria(1) = "工区领导"
Criteria(2) = "经营组"

For bytIdx(0) = 1 To bytCnt(0)

    With ThisWorkbook.Sheets(bytIdx(0))
        bytCnt(1) = .UsedRange.Rows.Count
        For Index = 0 To 2
            .Cells(1, 2).AutoFilter Field:=2, Criteria1:=Criteria(Index)
            .Range(.Cells(1), .Cells(bytCnt(1), 12)).SpecialCells(xlCellTypeVisible).Copy _
            wb(Index).Sheets(bytIdx(0)).Cells(1)
        Next
        strName = .Name
        For Index = 0 To 2
            With wb(Index).Sheets(bytIdx(0))
                .Name = strName
                .UsedRange.EntireColumn.AutoFit
            End With
        Next
    End With
    bytIdx(1) = bytIdx(1) + 1
Next

For Index = 0 To 2
    wb(Index).Close True, ThisWorkbook.Path & "\" & Criteria(Index)
Next

Erase wb
Erase Criteria
Erase bytIdx
Erase bytCnt

Application.ScreenUpdating = True
End Sub

yijiboo

TO:BobPan
你的代码是完全可以的。但运行后，这个 汇总.xls 里的3个表的每一列都成了筛选

的样子（最好是原来状态）；另外，生成的3个文件里的每个表里都有“工作单位”

这一列和数据（恩，我的要求里是没有的这一列的）。

TO:lenghonghai

我是07版本的，运行时,提示下标越界.在" : Workbooks("汇总").Activate"这行.

还有噢，当数据量很大时候，比如这个 汇总.xls 里的3个表每个表都有1000行数据

，有300个不同的工作单位（就是要生成300个文件），代码里是不是要加点什么啊？

非常感谢！！

BobPan

QUOTE:

以下是引用yijiboo在2007-12-11 10:47:44的发言：

TO:BobPan
你的代码是完全可以的。但运行后，这个 汇总.xls 里的3个表的每一列都成了筛选

的样子（最好是原来状态）；另外，生成的3个文件里的每个表里都有“工作单位”

这一列和数据（恩，我的要求里是没有的这一列的）。

TO:lenghonghai

我是07版本的，运行时,提示下标越界.在" : Workbooks("汇总").Activate"这行.

还有噢，当数据量很大时候，比如这个 汇总.xls 里的3个表每个表都有1000行数据

，有300个不同的工作单位（就是要生成300个文件），代码里是不是要加点什么啊？

非常感谢！！

1.数据量这么大的时候，我的代码不可取，建议使用lenghonghai的代码，所以不再更新

2.下标越界: Workbooks("汇总").Activate

   将"汇总"改为"汇总.xls"试试

shuyee

为什么不用数据查询呢?很棒的.

mou250

看了看lenghonghai的代码，做了局部的修改，但还是有问题不懂

'下面是sheet1的代码

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim sh As Worksheet, bo1 As Workbook, bo2 As Workbook, bo3 As Workbook
Dim sh1 As Worksheet, arr, j%, m%, n%
Dim d As Object, x%, i%
m = 2: n = 1
Set d = CreateObject("scripting.dictionary")
For Each sh In Worksheets
    x = sh.Range("b65536").End(xlUp).Row
    For i = 2 To x
        If Not d.exists(sh.Range("b" & i).Value) Then
            d.Add sh.Range("b" & i).Value, ""
        End If
    Next i
Next sh
arr = d.keys
For i = 0 To UBound(arr)
    Set bo1 = Workbooks.Add: Workbooks("汇总.xls").Activate

'将原有的“汇总”改为"汇总.xls"就不会有下标越界的情况了
    For Each sh In Worksheets
        x = sh.Range("a65536").End(xlUp).Row
        Set sh1 = bo1.Worksheets(n)
        sh1.Name = sh.Name
        sh.Rows(1).Copy sh1.Range("a" & 1)

'添加上面一句可以满足生成的每个表都有表头
        For j = 2 To x
            If sh.Range("b" & j).Value = arr(i) Then
                sh.Rows(j).Copy sh1.Range("a" & m)
                m = m + 1
            End If
        Next j
        m = 2: n = n + 1
    Next sh
    bo1.SaveAs ThisWorkbook.Path & "\" & arr(i) & ".xls"
    bo1.Close True: n = 1
Next i
Application.ScreenUpdating = True
End Sub

leng的思路特别好，我看了半天才弄明白。

因为刚开始学习VBA，许多语法都不熟。

第一，上面的程序段中最后由一个close true，这个方法没有在帮助上查到，只查到了close

第二，完全看不明白leng在sheet2中的程序了，估计应该是按照同样的规则向sheet1生成的books中添加数据的意思。

第三，yijiboo提出的去掉工作单位一列和添加汇总的程序，应该是添加在sheet1中就足够了吧