表格按特定条件拆分

parcal

由于工作的需要，从公司的系统下载数据后，然后按"工站"来拆分表格，
如下图，

1，表1的数据，分拆成表2的数据，且每数量呈"递减"排列。
2，请帮忙把数据范围增加到最大。

求助大神打赏个VBA。

表1


表2

chaohuahch

问题本身不是很复制，可以用字典的方式解决，但是不知道你表2的样式，是有固定的格式，还是重新生成的。

hefuqing

1. Sub sdd()
   
2. Dim brr(), crr()
   
3. arr = Sheet1.[A1].CurrentRegion
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d1 = CreateObject("scripting.dictionary")
   
6. For i = 2 To UBound(arr)
   
7. d1(arr(i, 2)) = ""
   
8. d(arr(i, 2) & "-" & arr(i, 10)) = d(arr(i, 2) & "-" & arr(i, 10)) + 1
   
9. Next i
   
10. k = d.keys
    
11. t = d.items
    
12. k1 = d1.keys
    
13. For i = 0 To d.Count - 1
    
14. n = n + 1
    
15. ReDim Preserve brr(1 To 3, 1 To n)
    
16. brr(1, n) = Split(k(i), "-")(0)
    
17. brr(2, n) = Split(k(i), "-")(1)
    
18. brr(3, n) = t(i)
    
19. Next i
    
20. 
    
21. For i = 0 To d1.Count - 1
    
22. For j = 1 To UBound(brr, 2)
    
23. If brr(1, j) = k1(i) Then
    
24. n1 = n1 + 1
    
25. ReDim Preserve crr(1 To 3, 1 To n1)
    
26. crr(1, n1) = n1
    
27. crr(2, n1) = brr(2, j)
    
28. crr(3, n1) = brr(3, j)
    
29. End If
    
30. Next j
    
31. Sheet2.Cells(Sheet2.Range("b65536").End(xlUp).Row + 4, 2).Resize(UBound(crr, 2), 3) = Application.Transpose(crr)
    
32. n1 = 0
    
33. Next i
    
34. 
    
35. End Sub
    

复制代码

iwangyi

Sub cc()
Set CN = CreateObject("adodb.connection")
CN.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
Sql = "SELECT DISTINCT 工站 FROM [表1$]"
Set rs = CN.Execute(Sql)
Do Until rs.EOF
gz = rs.FIELDS(0)
N = Sheets("表2").[c65536].End(3).Row
Cells(N + 1, 2) = gz
Cells(N + 1, 2).Interior.ColorIndex = 3
Cells(N + 1, 2).Font.Name = "黑体"
Cells(N + 1, 2).HorizontalAlignment = xlCenter
Range(Cells(N + 1, 2), Cells(N + 1, 6)).Merge
Cells(N + 2, 2).Resize(, 5) = Array("序号", "DEFECT PHENOMENON(不良現象)", "Q'TY 數 量", "DRI 負責人", "Due Date 完成日")
SQLL = "SELECT 失敗項,count(失敗項)  FROM [表1$] where 工站='" & gz & "' group by 失敗項 order by count(失敗項) desc"
Range("c" & N + 4).CopyFromRecordset CN.Execute(SQLL)
Range("B" & N + 1).CurrentRegion.Borders(xlDiagonalDown).LineStyle = xlNone
rs.movenext
Loop
End Sub

iwangyi

附件请参考

parcal

chaohuahch 发表于 2018-8-22 19:30
问题本身不是很复制，可以用字典的方式解决，但是不知道你表2的样式，是有固定的格式，还是重新生成的。

是重新生产的

parcal

iwangyi 发表于 2018-8-22 20:50
附件请参考

可以留个联系方式吗