求助一段VBA代码 解决数据抽取和填入的问题

wjxin163

感谢大神进来看帖！
简单来说，问题就是要抽取sheet2中特定表头对应的表格数据，然后填在Sheet1中的相应表格内，而且有一个数据累加的过程。详细情况在附件表格中会有说明，希望大神给个代码解决问题。

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, k, dic(1), t, col
  For i = 0 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  With Sheets("sheet2")
    For i = 1 To .Cells(Rows.Count, "a").End(xlUp).Row
      If .Cells(i, "a") = "主动方" Then
        col = .Cells(i, Columns.Count).End(xlToLeft).Column
        arr = .Cells(i, "a").Resize(col, col)
        For j = 2 To UBound(arr, 1)
          If Not dic(0).exists(arr(j, 1)) Then dic(0)(arr(j, 1)) = vbNullString
          For k = 2 To UBound(arr, 2)
            t = arr(j, 1) & "|" & arr(1, k)
            If j = k Then
              dic(1)(t) = "\"
            Else
              dic(1)(t) = dic(1)(t) + arr(j, k)
            End If
        Next k, j
        i = i + UBound(arr, 1)
      End If
    Next
  End With
  ReDim arr(1 To dic(0).Count + 1, 1 To dic(0).Count + 1)
  t = dic(0).keys
  For i = 2 To UBound(arr, 1)
    arr(i, 1) = t(i - 2): arr(1, i) = t(i - 2)
  Next
  For i = 2 To UBound(arr, 1)
    For j = 2 To UBound(arr, 2)
      arr(i, j) = dic(1)(arr(i, 1) & "|" & arr(1, j))
  Next j, i
  Sheets("sheet1").[b2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub

莫名v微笑

1. Sub 测试12()
   
2. Dim arr, brr
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set s = New Collection
   
5. arr = Sheets(1).UsedRange
   
6. brr = Sheets(2).UsedRange
   
7. For i = 2 To UBound(brr)
   
8. If brr(i, 1) = "主动方" Then s.Add i
   
9. Next
   
10. brr = Sheets(2).Cells(s(1), 1).CurrentRegion
    
11. For i = 3 To UBound(brr)
    
12. For u = 2 To UBound(brr, 2)
    
13. If Not d.exists(brr(i, 1) & brr(2, u)) And IsNumeric(brr(i, u)) Then d(brr(i, 1) & brr(2, u)) = brr(i, u)
    
14. Next
    
15. Next
    
16. For p = 2 To s.Count
    
17. brr = Sheets(2).Cells(s(p), 1).CurrentRegion
    
18. For i = 2 To UBound(brr)
    
19. For u = 2 To UBound(brr, 2)
    
20. If d.exists(brr(i, 1) & brr(1, u)) And IsNumeric(brr(i, u)) Then d(brr(i, 1) & brr(1, u)) = d(brr(i, 1) & brr(1, u)) + brr(i, u)
    
21. If Not d.exists(brr(i, 1) & brr(1, u)) And IsNumeric(brr(i, u)) Then d(brr(i, 1) & brr(1, u)) = brr(i, u)
    
22. Next
    
23. Next
    
24. Next
    
25. For i = 3 To UBound(arr)
    
26. For u = 3 To UBound(arr, 2)
    
27. If d.exists(arr(i, 2) & arr(2, u)) Then arr(i, u) = d(arr(i, 2) & arr(2, u))
    
28. Next
    
29. Next
    
30. Sheets(1).Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
31. Set d = Nothing
    
32. Set s = Nothing
    
33. Set arr = Nothing
    
34. Set brr = Nothing
    
35. End Sub
    

复制代码

wjxin163

一把小刀闯天下 发表于 2018-8-14 10:47
Option Explicit

Sub test()

下午试了一下  问题完美解决  
太神奇了！  十分感谢！！

wjxin163

莫名v微笑 发表于 2018-8-14 15:39

问题已解决  感谢

wjxin163

一把小刀闯天下 发表于 2018-8-14 10:47
Option Explicit

Sub test()

使用过程中出了些问题，在这里追问一下 ，烦请高手抽空解答。
到后面我需要抽取的数据，小表格中每个单元格都有，而且数据较多，排了1100行，然后代码就不管用了，报错类型不匹配。请问这是什么问题，可以通过调整代码来解决吗？


表格在附件中，感谢！

一把小刀闯天下

'检查一下第9行数据有效性。中文跟数字能相加？给你写代码还得我来给你检查数据有效性？

'如果再有问题就是表格规范性问题了

在dic(1)(t) = dic(1)(t) + arr(j, k) 行上面插入一行：

If Not IsNumeric(arr(j, k)) Then MsgBox Format(i, "检查0行开始数据块数据有效性！"): Exit Sub