Hsieh

回復 3# sax868
確實無法了解你的需求
執行以下程序，自動生成新工作表，得到Updated Data的資料
再來討論你的第2個問題

1. Sub Ex()
   
2. Dim Sh As Worksheet, Ar()
   
3. For Each Sh In Sheets
   
4. With Sh
   
5.   If UBound(Filter(Array("Currency", "DATA", "Updated Data"), .Name, True)) < 0 Then
   
6.   ReDim Preserve Ar(57, x)
   
7.   If IsEmpty(Ar(0, 0)) Then
   
8.      Ar(0, x) = .[B1].Value: Ar(1, x) = .[B2].Value: Ar(2, x) = .[D1].Value
   
9.      s = 3
   
10.      For Each a In .[A11:BB11].Value
    
11.         Ar(s, x) = a
    
12.         s = s + 1
    
13.      Next
    
14.      x = x + 1
    
15.    End If
    
16.    r = 12
    
17.    Do Until .Cells(r, 1) = ""
    
18.       ReDim Preserve Ar(57, x)
    
19.          Ar(0, x) = .[C1].Value: Ar(1, x) = .[C2].Value: Ar(2, x) = .[E1].Value
    
20.          s = 3
    
21.          For Each a In .Range(.Cells(r, "A"), .Cells(r, "BB")).Value
    
22.             Ar(s, x) = a
    
23.             s = s + 1
    
24.          Next
    
25.          x = x + 1: r = r + 1
    
26.    Loop
    
27.   
    
28.   End If
    
29. End With
    
30. Next
    
31. With Sheets.Add(after:=Sheets(Sheets.Count))
    
32. .[A1].Resize(x, 57) = Application.Transpose(Ar)
    
33. End With
    
34. End Sub

複製代碼

Hsieh

回復 6# sax868


    這一行是寫入值的方法
出現錯誤可能是X=0吧
把出現錯誤的檔案上傳看看

Hsieh

回復 8# sax868
這種問題常發生在陣列元素的字元數超過256個字元所產生
導致無法正確操作陣列轉置
改成一一給值就可以

1.      x = x + 1
   
2.    End If
   
3.    r = 12
   
4.    Do Until .Cells(r, 1) = ""
   
5.       ReDim Preserve Ar(57, x)
   
6.          Ar(0, x) = .[C1].Value: Ar(1, x) = .[C2].Value: Ar(2, x) = .[E1].Value
   
7.          s = 3
   
8.          For Each a In .Range(.Cells(r, "A"), .Cells(r, "BB")).Value
   
9.             Ar(s, x) = a
   
10.             s = s + 1
    
11.          Next
    
12.          x = x + 1: r = r + 1
    
13.    Loop
    
14.   End If
    
15. End With
    
16. Next
    
17. With Sheets.Add(after:=Sheets(Sheets.Count))
    
18. For i = 0 To UBound(Ar, 2)
    
19.    For j = 0 To 56
    
20.    .[A1].Offset(i, j) = Ar(j, i)
    
21.    Next
    
22. Next
    
23. End With
    
24. End Sub

複製代碼

Hsieh

回復 11# sax868
是要把"Updated Data"對應的值寫入每個工作表的12列以下之AU欄嗎?

1. Sub Ex()
   
2. Dim Sh As Worksheet, Ar()
   
3. Set d = CreateObject("Scripting.Dictionary") '創建字典物件儲存"Updated Data"對應的值
   
4. For Each Sh In Sheets
   
5. With Sheets("Updated Data")
   
6.    For Each a In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
   
7.      d(a & a.Offset(, 3) & a.Offset(, 12)) = a.Offset(, 49).Value '以A、D、M為索引存入AX欄位的值
   
8.     Next
   
9. End With
   
10. With Sh
    
11.   If UBound(Filter(Array("Currency", "DATA", "Updated Data"), .Name, True)) < 0 Then '除了這些工作表以外執行
    
12.   ReDim Preserve Ar(57, x) '擴增陣列
    
13.   If IsEmpty(Ar(0, 0)) Then '，如果陣列還沒建立先寫入標題列
    
14.      Ar(0, x) = .[B1].Value: Ar(1, x) = .[B2].Value: Ar(2, x) = .[D1].Value
    
15.      s = 3
    
16.      For Each a In .[A11:BB11].Value
    
17.         Ar(s, x) = a
    
18.         s = s + 1
    
19.      Next
    
20.      x = x + 1
    
21.    End If
    
22.    r = 12 '從第12列以下開始讀入資料到陣列中
    
23.    Do Until .Cells(r, 1) = "" '直到A欄為空白為止
    
24.       ReDim Preserve Ar(57, x)
    
25.          Ar(0, x) = .[C1].Value: Ar(1, x) = .[C2].Value: Ar(2, x) = .[E1].Value
    
26.          s = 3
    
27.          For Each a In .Range(.Cells(r, "A"), .Cells(r, "BB")).Value '將A:BB欄位讀入陣列
    
28.             Ar(s, x) = a
    
29.             s = s + 1
    
30.          Next
    
31.          .Cells(r, "AU") = d(Ar(0, x) & Ar(3, x) & Ar(12, x)) '將工作表的AU欄位寫入對應的Updated Data值
    
32.          x = x + 1: r = r + 1 '下一列
    
33.    Loop
    
34.   
    
35.   End If
    
36. End With
    
37. Next
    
38. With Sheets.Add(after:=Sheets(Sheets.Count)) '新增工作表於最後
    
39. For i = 0 To UBound(Ar, 2)
    
40.    For j = 0 To 56
    
41.    .[A1].Offset(i, j) = Ar(j, i) '一一將陣列元素寫入儲存格
    
42.    Next
    
43. Next
    
44. End With
    
45. End Sub

複製代碼

Hsieh

回復 13# sax868

1. Sub InputData()
   
2. Dim Sh As Worksheet, Ar()
   
3. Set d = CreateObject("Scripting.Dictionary") '創建字典物件儲存"Updated Data"對應的值
   
4. Set d1 = CreateObject("Scripting.Dictionary") '創建字典物件儲存"Updated Data"對應的值
   
5. 
   
6. With Sheets("Updated Data")
   
7.    For Each a In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
   
8.      d(a & a.Offset(, 3) & a.Offset(, 12)) = a.Offset(, 49).Value '以A、D、M為索引存入AX欄位的值
   
9.      d1(a & a.Offset(, 3) & a.Offset(, 12)) = a.Offset(, 37).Value '以A、D、M為索引存入AL欄位的值
   
10.    Next
    
11. End With
    
12. For Each Sh In Sheets
    
13. With Sh
    
14.    r = 12 '從第12列以下開始讀入資料到陣列中
    
15.    Do Until .Cells(r, 1) = "" '直到A欄為空白為止
    
16.          .Cells(r, "AU") = d(.[C1] & .Cells(r, "A") & .Cells(r, "J")) '將工作表的AU欄位寫入對應的Updated Data值
    
17.          .Cells(r, "AI") = d1(.[C1] & .Cells(r, "A") & .Cells(r, "J")) '將工作表的AI欄位寫入對應的Updated Data值
    
18.           r = r + 1 '下一列
    
19.    Loop
    
20. End With
    
21. Next
    
22. End Sub

複製代碼

Hsieh

回復 16# sax868

1. Sub InputData()
   
2. 
   
3. Dim Sh As Worksheet, Ar()
   
4. 
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. 
   
7. Set d1 = CreateObject("Scripting.Dictionary")
   
8. 
   
9. 
   
10. With Sheets("Updated Data")
    
11. 
    
12.    For Each a In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
    
13. 
    
14.     If a.Offset(, 49) <> "" Then d(a & a.Offset(, 3) & a.Offset(, 12)) = a.Offset(, 49).Value   'AX有值才執行
    
15. 
    
16.     If a.Offset(, 37) <> "" Then d1(a & a.Offset(, 3) & a.Offset(, 12)) = a.Offset(, 37).Value   'AL有值才執行
    
17. 
    
18.    Next
    
19. 
    
20. End With
    
21. 
    
22. For Each Sh In Sheets
    
23. 
    
24. With Sh
    
25. 
    
26.    r = 12
    
27. 
    
28.    Do Until .Cells(r, 1) = ""
    
29. 
    
30.          .Cells(r, "AU") = d(.[C1] & .Cells(r, "A") & .Cells(r, "J"))
    
31. 
    
32.          .Cells(r, "AI") = d1(.[C1] & .Cells(r, "A") & .Cells(r, "J"))
    
33. 
    
34.           r = r + 1
    
35. 
    
36.    Loop
    
37. 
    
38. End With
    
39. 
    
40. Next
    
41. 
    
42. End Sub

複製代碼

Hsieh

回復 19# sax868
至於你整體流程我並不清楚
自動存檔可參考下面連結
自訂Applicatoin事件/監控所有活頁簿/做成增益集