根据D列提取到相关的工作表

chenhu1981

提取到指定工作表.rar (31.39 KB, 下载次数: 15)

2017-10-25 09:20 上传

点击文件名下载附件

大家好，能否根据工作表中D列的内容，提取相应的内容到指定工作表，比如“10月份木纹机台产量”表中的D2单元格为“木纹5#机”，那么就提取该行到“5#”工作表中的非空行的对下一行中，不知是否能实现，谢谢！

liulang0808

1. Sub aaa()
   
2.     Application.ScreenUpdating = False
   
3.     arr = Sheets(1).UsedRange
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     With Sheets(1)
   
6.         For j = 2 To UBound(arr)
   
7.             For i = 1 To 6
   
8.                 If InStr(arr(j, 4), i) > 0 Then
   
9.                     If Not d.exists(i) Then
   
10.                         Set d(i) = Union(.[a1:ab1], .Cells(j, 1).Resize(1, 28))
    
11.                     Else
    
12.                         Set d(i) = Union(d(i), .Cells(j, 1).Resize(1, 28))
    
13.                     End If
    
14.                 End If
    
15.             Next i
    
16.         Next j
    
17.     End With
    
18.     For j = 0 To d.Count - 1
    
19.         With Sheets(d.keys()(j) & "#")
    
20.             If Len(.[a1]) = 0 Then
    
21.                 r = 1
    
22.             Else
    
23.                 r = .UsedRange.Rows.Count + 2
    
24.             End If
    
25.             d.items()(j).Copy .Cells(r, 1)
    
26.             
    
27.             For i = r + 1 To .Cells(Rows.Count, 2).End(3).Row
    
28.                 .Cells(i, 1) = i - r
    
29.             Next i
    
30.         End With
    
31.     Next j
    
32.     Application.ScreenUpdating = True
    
33. End Sub

复制代码

liulang0808

附件内容供参考

lsc900707

按d列拆分工作表就好。

jsgj2023

看看是否有帮助!

Kaohsing

试试

1. Sub getData(sName$)
   
2.     Dim arr, ghb(1 To 2000, 1 To 28)
   
3.     Dim i%, k%, j%
   
4.     arr = Sheets("10月份木纹机台产量").UsedRange
   
5.     For i = 2 To UBound(arr)
   
6.         If InStr(arr(i, 4), sName$) Then
   
7.             k = k + 1
   
8.             ghb(k + 1, 1) = k
   
9.             For j = 2 To UBound(arr, 2)
   
10.                 ghb(k + 1, j) = arr(i, j)
    
11.             Next
    
12.         End If
    
13.     Next
    
14.     If k = 0 Then GoTo ghb
    
15.     For i = 1 To UBound(arr, 2)
    
16.         ghb(1, i) = arr(1, i)
    
17.     Next
    
18.     With Sheets(sName)
    
19.         .Cells.Clear
    
20.         .[a1].Resize(k, 28) = ghb
    
21.     End With
    
22. ghb:
    
23. End Sub
    
24. Sub kaohsing()
    
25.     Dim sh As Worksheet
    
26.     Application.ScreenUpdating = False
    
27.     For Each sh In Worksheets
    
28.         If sh.Name <> "10月份木纹机台产量" Then
    
29.             getData sh.Name
    
30.         End If
    
31.     Next
    
32.     Application.ScreenUpdating = True
    
33.     MsgBox " job is okey"
    
34. End Sub

复制代码

Kaohsing

还要审核，直接贴图得了

chenhu1981

谢谢版主，我是想将数据不断分类汇总到各个相应工作表，不想通过删除新增工作表的方法。而是在原工作表上添加数据

chenhu1981

lsc900707 发表于 2017-10-25 10:08
按d列拆分工作表就好。

现在想要不断汇总到各个工作表，因为是从ERP下载每日的数据，数据是不断汇总到各个相应的工作表中

Kaohsing

chenhu1981 发表于 2017-10-25 10:53
现在想要不断汇总到各个工作表，因为是从ERP下载每日的数据，数据是不断汇总到各个相应的工作表中

把第19句删掉即可。