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

lenghonghai

有点麻烦。

lenghonghai

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("汇总").Activate
    For Each sh In Worksheets
        x = sh.Range("a65536").End(xlUp).Row
        Set sh1 = bo1.Worksheets(n)
        sh1.Name = sh.Name
        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

看看是不是这个意思。

lenghonghai

phh7EzrB.rar (20.18 KB, 下载次数: 21)

2007-12-11 09:19 上传

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

具体请查看附件，你下载附件后，点击这个工作表里面的按钮，就会自动生成另外三个工作表了。

lenghonghai

QUOTE:

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

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

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

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

TO:lenghonghai

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

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

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

非常感谢！！

Set sh1 = bo1.Worksheets(n)
第一个问题我帮不了你，我的2003版本运行正常，对于你说要生成300个文件，你说的意思是B列有可以出现300个不同的值吗？如果是那样的话，也应该没有问题的，如果是生成300个文件已经可以了，如果在一个工作表中生成300多个工作表，不可以吧？一个工作簿好象最多可以容纳下255个。

哦对了，你用的2007版本，不知道能一起容纳下多少个呢？

如果可以容纳的话，可以把上一句代码略微改动一下，也就是改成：set  sh1=bo1.worksheets.add

这样的话，应该就可以了。

lenghonghai

QUOTE:

以下是引用mou250在2007-12-18 10:06:11的发言：

看了看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中就足够了吧

close true是关闭这个工作簿，并进行保存。

冲天妖狐

佩服啊！
能否弄个反向的：就是把文件夹内的文件（比如这个代码生成的文件）中的数据合并到一个工作表……