[已解决]请高手帮忙，解决分类问题！

flh1000 · 发表于 2010-3-15 17:08

附件明细表中公司名相同的新建一张表复制过去，也就是要把总表的内容拆开，分84张表，手动复制太慢，请高手帮梦写程序！总共84个公司

pMxltO7M.rar (90.06 KB, 下载次数: 0)

坏多多 · 发表于 2010-3-15 17:57

不对呀，好象是141个

坏多多 · 发表于 2010-3-15 18:09

Sub t()
Application.ScreenUpdating = False
Dim i As Integer, j As Integer, k As Integer, l As Integer
Dim arr, arr1, arr2
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheet1
arr = .Range("A1:L" & .[b65536].End(xlUp).Row)
End With
For i = 2 To UBound(arr)
d(arr(i, 2)) = ""
Next
arr1 = d.keys
ReDim arr2(1 To UBound(arr), 1 To UBound(arr, 2))
k = 1

For i = 0 To UBound(arr1)
ReDim arr2(1 To UBound(arr), 1 To UBound(arr, 2))
    For l = 1 To UBound(arr, 2)
       arr2(1, l) = arr(1, l)
     Next
    For j = 2 To UBound(arr)
        If arr(j, 2) = arr1(i) Then
            k = k + 1
            For l = 1 To UBound(arr, 2)
                arr2(k, l) = arr(j, l)
            Next
        End If
    Next
    k = 1
    Sheets.Add
    With ActiveSheet
        .Name = arr1(i)
        .[a1].Resize(UBound(arr), UBound(arr, 2)) = arr2

    End With
Next
Set d = Nothing
Application.ScreenUpdating = True
End Sub

[此贴子已经被作者于2010-3-15 18:35:17编辑过]

帅 · 发表于 2010-3-15 18:13

学习[em02][em02][em02]

flh1000 · 发表于 2010-3-15 18:30

你好，不对啊，每个工作表里只放一个公司的，但是你这个放了好多个公司的！请帮忙再看看，谢谢！[em04]

坏多多 · 发表于 2010-3-15 18:36

已经修改了

枯禅 · 发表于 2010-3-15 18:56

9DdBoZlf.rar (202.86 KB, 下载次数: 10)

		自动登录	找回密码
密码			注册