返回列表 上一主題 發帖

[發問] 請問如何分別撰寫VBA，使特定工作表的特定值合併，再抓特定值回原始檔

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
106  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-5-8 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2012-5-4 21:27 | 顯示全部帖子
回復 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
複製代碼
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
106  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-5-8 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 2012-5-6 06:42 | 顯示全部帖子
回復 6# sax868


    這一行是寫入值的方法
出現錯誤可能是X=0吧
把出現錯誤的檔案上傳看看
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
106  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-5-8 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
3#
發表於 2012-5-6 23:09 | 顯示全部帖子
回復 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
複製代碼
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
106  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-5-8 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
4#
發表於 2012-5-8 20:21 | 顯示全部帖子
回復 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
複製代碼
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
106  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-5-8 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
5#
發表於 2012-5-8 22:00 | 顯示全部帖子
回復 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"對應的值

  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
複製代碼
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
106  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-5-8 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
6#
發表於 2012-5-10 19:49 | 顯示全部帖子
本帖最後由 Hsieh 於 2012-5-10 19:50 編輯

回復 16# sax868
  1. Sub InputData()

  3. Dim Sh As Worksheet, Ar()

  5. Set d = CreateObject("Scripting.Dictionary")

  7. Set d1 = CreateObject("Scripting.Dictionary")


  10. With Sheets("Updated Data")

  12.    For Each a In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))

  14.     If a.Offset(, 49) <> "" Then d(a & a.Offset(, 3) & a.Offset(, 12)) = a.Offset(, 49).Value   'AX有值才執行

  16.     If a.Offset(, 37) <> "" Then d1(a & a.Offset(, 3) & a.Offset(, 12)) = a.Offset(, 37).Value   'AL有值才執行

  18.    Next

  20. End With

  22. For Each Sh In Sheets

  24. With Sh

  26.    r = 12

  28.    Do Until .Cells(r, 1) = ""

  30.          .Cells(r, "AU") = d(.[C1] & .Cells(r, "A") & .Cells(r, "J"))

  32.          .Cells(r, "AI") = d1(.[C1] & .Cells(r, "A") & .Cells(r, "J"))

  34.           r = r + 1

  36.    Loop

  38. End With

  40. Next

  42. End Sub
複製代碼
學海無涯_不恥下問

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
106  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-5-8 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
7#
發表於 2012-5-13 17:41 | 顯示全部帖子
回復 19# sax868
至於你整體流程我並不清楚
自動存檔可參考下面連結
自訂Applicatoin事件/監控所有活頁簿/做成增益集
學海無涯_不恥下問

TOP

        靜思自在 : 對父母要知恩，感恩、報恩。
返回列表 上一主題