p6703

如附件每日會有資料填於Sheet上，可否使用VBA將資料套取於Sheet2上的表格格式，懇請各位高手教導，在此先謝謝:)

主要依"交期"欄位會有分多筆，於需求日需加總同訂單數，而交期欄位各別比對其對應的符合日期欄位

Book1.rar (2.03 KB)

下載次數: 25

2012-4-24 23:35

register313

回復 1# p6703


看不懂如何對應? 如何填入sheet2?
給個範例 填入excel表內 較易了解

c_c_lai

回復 2# register313
他的意思應該是：

下載 (20.39 KB)

2012-4-25 06:44

p6703

感謝c_c_lai 兄的補充說明，的確此就是小弟所想要的功能

但再額外補充說明一下,就如符件中的Sheet1上的訂單資料，其實有三筆是重覆的（因交期因素把它拆開來），但套到Sheet2時要匯整成一項（需求數加總，並依交期數分別套在對應的日期上）

register313

回復 4# p6703

程式語法不理想,尚有改進空間,請指正

1. Sub zz()
   
2. Set d = CreateObject("scripting.dictionary")
   
3. With Sheet1
   
4.   ar = .Range("A2:F" & .[F2].End(xlDown).Row)
   
5.   For i = 1 To UBound(ar)
   
6.     x = ar(i, 1) & "," & ar(i, 2) & "," & ar(i, 3)
   
7.     If Not d.exists(x) Then d.Add x, ar(i, 4) Else d(x) = d(x) + ar(i, 4)
   
8.   Next i
   
9. End With
   
10. a = d.keys: b = d.items
    
11. c = 0
    
12. With Sheet2
    
13.   .[A1].CurrentRegion.Offset(1, 0) = ""
    
14.   For i = 0 To d.Count - 1
    
15.     y = Split(a(i), ",")
    
16.     .Range("A2").Offset(c, 0).Resize(1, 3) = y
    
17.     .Range("D2").Offset(c, 0).Resize(2, 1) = Application.Transpose(Array("需求日", "交期"))
    
18.     For j = 2 To Sheet1.[A2].End(xlDown).Row
    
19.       x = Sheet1.Cells(j, 1) & "," & Sheet1.Cells(j, 2) & "," & Sheet1.Cells(j, 3)
    
20.       If a(i) = x Then
    
21.         E = Application.Match(Sheet1.Cells(j, 5), .Range(.[E1], .[E1].End(xlToRight)), 0)
    
22.         .Range("E2").Offset(c, E - 1) = d(x)
    
23.         F = Application.Match(Sheet1.Cells(j, 6), .Range(.[E1], .[E1].End(xlToRight)), 0)
    
24.         .Range("E3").Offset(c, F - 1) = Sheet1.Cells(j, 4)
    
25.       End If
    
26.     Next j
    
27.     c = c + 2
    
28.   Next i
    
29. End With
    
30. End Sub

複製代碼

p6703

感謝register313兄指教，但小弟將程式碼複製執行巨集時，卻跑出"執行階段錯誤 '424': 此處需要物件"的警告視窗，停在.[A1].CurrentRegion.Offset(1, 0) = ""此列，不知何故???

register313

回復 6# p6703

p6703

感謝register313兄，可以執行了，但小弟不明白，程式碼一樣，因何小弟自己複製貼上的就不行呢???還有小弟接觸vba不久，不知是否可請register313兄針對程式碼小小說明一下，謝謝...

p6703

小弟先摸索看看了.再次感謝register313兄^^

Hsieh

回復 4# p6703

1. Sub Ex()
   
2. Dim A As Range
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. With Sheet2
   
5. n = .Cells(1, .Columns.Count).End(xlToLeft).Column - 1
   
6. s = Day(.[E1])
   
7. With Sheet1
   
8.    For Each A In .Range(.[A2], .[A2].End(xlDown))
   
9. ReDim ar(0 To 1, 0 To n)
   
10.        m = A & "," & A.Offset(, 1) & "," & A.Offset(, 2)
    
11.        If IsEmpty(d(m)) Then
    
12.        GoTo 10
    
13.        Else
    
14.        For i = 0 To 1
    
15.          For j = 0 To n
    
16.            ar(i, j) = d(m)(i, j)
    
17.          Next
    
18.        Next
    
19.        End If
    
20. 10
    
21.        x = Day(A.Offset(, 4)) - s + 4 '需求日
    
22.        y = Day(A.Offset(, 5)) - s + 4 '交期
    
23.        For i = 0 To 2
    
24.          ar(0, i) = A.Offset(, i)
    
25.        Next
    
26.        ar(0, 3) = "需求日"
    
27.        ar(1, 3) = "交期"
    
28.        ar(0, x) = ar(0, x) + A.Offset(, 3) '需求
    
29.        ar(1, y) = A.Offset(, 3)
    
30.        d(m) = ar
    
31.        Erase ar
    
32.    Next
    
33. End With
    
34. r = 2
    
35. For Each ky In d.keys
    
36.   .Cells(r, 1).Resize(2, n + 1) = d(ky)
    
37.   r = r + 2
    
38. Next
    
39. End With
    
40. End Sub

複製代碼