123
返回列表 上一主題 發帖

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

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
12# 跳轉到 »
發表於 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

sax868

帖子
37 
主題
9 
精華
0 
積分
61 
點名
0  
作業系統
Windows7 
軟體版本
office 2010 
閱讀權限
20 
性別
女 
註冊時間
2011-4-26 
最後登錄
2014-7-28 
11#
發表於 2012-5-8 17:13 | 只看該作者
#VALUE!.zip (134.69 KB) 回復 9# Hsieh
親愛的超級版主及各位高手大大們午安：

我剛用我兩光三腳貓的學習錄巨集，把我想要的方式表達出來了！(請詳見附檔)
試想煩請大大們幫我看一下能不能縮短VBA以提高excel 運算的速度呢?
另外，因為我只會錄單一張工作表，請問可不可以設定要一次跑所有檔案裡的工作表,除了'Currency'、'DATA'及'Updated Data'三張工作表以外呢?
*我看超級版主Hsieh大寫的這個想說插入即可，可是我不會用...-_-lll
With Sh
  If UBound(Filter(Array("Currency", "DATA", "Updated Data"), .Name, True)) < 0 Then
  ReDim Preserve Ar(57, x)

真不好意思，麻煩大家了!

努力游出幼幼班的
弱女子留

TOP

sax868

帖子
37 
主題
9 
精華
0 
積分
61 
點名
0  
作業系統
Windows7 
軟體版本
office 2010 
閱讀權限
20 
性別
女 
註冊時間
2011-4-26 
最後登錄
2014-7-28 
10#
發表於 2012-5-7 22:55 | 只看該作者
本帖最後由 sax868 於 2012-5-8 12:10 編輯

not ok.rar (55.18 KB) 回復 9# Hsieh

感謝超級版主的救命之恩!! 超級好用!大概等2分鐘答案全跑出來，這真的太神奇了!!
接下來的第二個問題還得再煩請超級版主幫我解決...
我試著寫函數然後用錄巨集的方式可是無法每張工作表都一起改，以下是我的需求：
每一張工作表裡Filter(Array("Currency", "DATA", "Updated Data")的AI12至AI300值為:
若C1='Updated Data'裡的A:A欄且A12='Updated Data'!裡的D: D欄且J12='Updated Data'!裡的M:M欄，
則AI12值為'Updated Data'!AL:AL欄裡相對應的值，並且A12至A300值若為空格，AI12至AI300欄為空格，若有值則需計算；若AI12至AI300欄位值出現零則意將其值設為空格。

每一張工作表裡Filter(Array("Currency", "DATA", "Updated Data")的AU12至AU300值為:
若C1='Updated Data'裡的A:A欄且A12='Updated Data'!裡的D: D欄且J12='Updated Data'!裡的M:M欄，
則AI12值為'Updated Data'!AX:AX欄裡相對應的值，並且A12至A300值若為空格，AU12至AU300欄為空格，若有值則需計算；若AU12至AU300欄位值出現零則意將其值設為空格。

舉例: 煩請參考工作表'1033600-2013' AI12欄及AU12欄我的兩光函數這麼寫: =IF(A12="","",IF(AND(C1='Updated Data'!A2)+AND(A12='Updated Data'!D2)+AND(J12='Updated Data'!M2),'Updated Data'!AL2,""))   可是這招再另一張工作表'1006600-2013'就不靈光...:L

*剛剛我用Index+match好像可以靈光了!
例工作表'1033600-2013' ：
AI12欄 {=IF(A12="","",INDEX('Updated Data'!AL:AL,MATCH($C$1&$A12&$J12,'Updated Data'!A:A&'Updated Data'!D: D&'Updated Data'!M:M,0)))}
AU12欄 {=IF(A25="","",INDEX('Updated Data'!AX:AX,MATCH($C$1&$A25&$J25,'Updated Data'!A:A&'Updated Data'!D: D&'Updated Data'!M:M,0)))}

可是不知為啥一定得在最後按Ctrl+Shift+Enter才能跑出數據,這函數直接複製貼AI13:AI300時全變'#VALUE!'...

以上，希望有解釋清楚...

拜託...請超級版主抽空及各位高手大大救救我!!

幼幼班的弱女子留:$

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
9#
發表於 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

sax868

帖子
37 
主題
9 
精華
0 
積分
61 
點名
0  
作業系統
Windows7 
軟體版本
office 2010 
閱讀權限
20 
性別
女 
註冊時間
2011-4-26 
最後登錄
2014-7-28 
8#
發表於 2012-5-6 18:54 | 只看該作者
Desktop.zip (142.95 KB) 回復 7# Hsieh

謝謝Hsieh大的幫忙!真的很不好意思，因為這個檔案裡有很多別的檔案的連結跟其他前人寫的巨集(看不懂...)還有工作表也會隨MNo增加而增加，我有試著把一些工作表移除結果出現資料了，後來我把幾個跑不出資料的留住一些數據資料移除後本打算要寄給您參考，結果再跑一次居然出現資料了...

隨信附上這個出現"執行階段錯誤'13' : 型態不符合" 的數據給您供參考。
感激不盡!

幼稚園大班的
弱女子留

TOP

Hsieh

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

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


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

TOP

sax868

帖子
37 
主題
9 
精華
0 
積分
61 
點名
0  
作業系統
Windows7 
軟體版本
office 2010 
閱讀權限
20 
性別
女 
註冊時間
2011-4-26 
最後登錄
2014-7-28 
6#
發表於 2012-5-6 01:45 | 只看該作者
回復 5# sax868
抱歉!又是我...
我剛剛有試著把 .[A1].Resize(x, 57) = Application.Transpose(Ar)  這一行拿掉.結果開了一個新的資料表但內容是空白...

TOP

sax868

帖子
37 
主題
9 
精華
0 
積分
61 
點名
0  
作業系統
Windows7 
軟體版本
office 2010 
閱讀權限
20 
性別
女 
註冊時間
2011-4-26 
最後登錄
2014-7-28 
5#
發表於 2012-5-6 01:03 | 只看該作者
回復 4# Hsieh

真不好意思~首先，感謝Hsieh大大的幫忙! 在這檔案可以用但是到我的檔案跑時它出現 Run-time error '13': Type mismatch
請問這是甚麼呢?

自動降級成幼稚園大班的
弱女子留

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
4#
發表於 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

sax868

帖子
37 
主題
9 
精華
0 
積分
61 
點名
0  
作業系統
Windows7 
軟體版本
office 2010 
閱讀權限
20 
性別
女 
註冊時間
2011-4-26 
最後登錄
2014-7-28 
3#
發表於 2012-5-4 17:28 | 只看該作者
回復 2# register313

感謝register313 大大的訊速回覆!
可是跑不出資料耶~請問這跟版本有關嗎? 我是用office2010, W7.
它顯示一個視窗寫: Can't execute code in break mode
我就自己加開一個工作表鍵入Updated Data 然後再跑一遍 結果又出現: Run-time error '9': Subscript out of range
拜託救我...

TOP

        靜思自在 : 不要隨心所欲，要隨心教育自己。
123
返回列表 上一主題