[已解决]根据列字段不同提取数据

2828466

如附表所示:我想按部门名称不同将数据提取到不同的工作表并以该部门名称命名该工作表,请问该如何用VBA代码实现啊.哪位高手能帮帮忙.急求.

最佳答案

月排行榜 / 总排行榜

grf1973

2016-4-28 14:12

这个有标准答案的

1. Sub 生成()
   
2.     Dim bt As Range
   
3.     arr = [a1].CurrentRegion
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set bt = [a1:e1]
   
6.     For i = 2 To UBound(arr)
   
7.         x = arr(i, 2)
   
8.         If Not d.exists(x) Then
   
9.             Set d(x) = Union(bt, Cells(i, 1).Resize(1, 5))
   
10.         Else
    
11.             Set d(x) = Union(d(x), Cells(i, 1).Resize(1, 5))
    
12.         End If
    
13.     Next
    
14.     For Each x In d.keys
    
15.         Worksheets.Add after:=Sheets(Sheets.Count)
    
16.         d(x).Copy ActiveSheet.[a1]
    
17.         ActiveSheet.Name = x
    
18.     Next
    
19. End Sub

复制代码

跳转到最佳答案楼层

grf1973

这个有标准答案的

1. Sub 生成()
   
2.     Dim bt As Range
   
3.     arr = [a1].CurrentRegion
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set bt = [a1:e1]
   
6.     For i = 2 To UBound(arr)
   
7.         x = arr(i, 2)
   
8.         If Not d.exists(x) Then
   
9.             Set d(x) = Union(bt, Cells(i, 1).Resize(1, 5))
   
10.         Else
    
11.             Set d(x) = Union(d(x), Cells(i, 1).Resize(1, 5))
    
12.         End If
    
13.     Next
    
14.     For Each x In d.keys
    
15.         Worksheets.Add after:=Sheets(Sheets.Count)
    
16.         d(x).Copy ActiveSheet.[a1]
    
17.         ActiveSheet.Name = x
    
18.     Next
    
19. End Sub

复制代码

2828466

grf1973 发表于 2016-4-28 14:12
这个有标准答案的

非常感谢.我对VBA懂一点儿,正在学,懂一点儿基础的,对数组还不懂,请问职附件所示,按每个工作表名在逐次提取(就是不需要一次提取所有部门,每个部门工作 表为活动工作表时点击提取时可以提取当前活动工作表),这样是不是简单些,我按这个思路没写出来,不知按单个表逐个提取该怎么写呢,谢谢了.

grf1973

原来的很烦吗？还要怎么简单？你的意思是预先把所有部门的工作表建好，进入工作表时提取？

2828466

grf1973 发表于 2016-4-28 14:41
原来的很烦吗？还要怎么简单？你的意思是预先把所有部门的工作表建好，进入工作表时提取？

对,就是想进工作 时提取.你这个很简单了,但是我对VBA数组不了解,看不太明白,想弄个自己能明白便于自己随时修改的.

grf1973

这样反而麻烦。在每个部门对应的工作表里输入下面代码：

1. Private Sub Worksheet_Activate()
   
2.     bm = ActiveSheet.Name
   
3.     arr = Sheets(1).[a1].CurrentRegion
   
4.     n = 1       'n=1表示表头
   
5.     For i = 2 To UBound(arr)
   
6.         If arr(i, 2) = bm Then
   
7.             n = n + 1
   
8.             For j = 1 To UBound(arr, 2)
   
9.                 arr(n, j) = arr(i, j)
   
10.             Next
    
11.         End If
    
12.     Next
    
13.     If n > 1 Then
    
14.         Cells.ClearContents
    
15.         [a1].Resize(n, UBound(arr, 2)) = arr
    
16.     End If
    
17. End Sub
    

复制代码

2828466

grf1973 发表于 2016-4-28 16:28
这样反而麻烦。在每个部门对应的工作表里输入下面代码：

用这个试了下,也可以完成
Sub 分次提取()
Dim i As Integer
For i = 1 To 10000
If Sheets("汇总").Cells(i, 2) = ActiveSheet.Name Then
Sheets("汇总").Rows(i).Copy ActiveSheet.Range("a65536").End(xlUp).Offset(1, 0)
End If
Next
End Sub

grf1973

当然可以。不过如果数据量大的话会影响速度。

2828466

grf1973 发表于 2016-4-28 14:12
这个有标准答案的

你好。请问这个是不是用到了VBA的字典啊，不用字典可以完成吗

cacpssl

2828466 发表于 2016-4-28 14:32
非常感谢.我对VBA懂一点儿,正在学,懂一点儿基础的,对数组还不懂,请问职附件所示,按每个工作表名在逐次提 ...

为什么下载不了附件？