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

---

作者: sax868    時間: 2012-5-4 11:57     標題: 請問如何分別撰寫VBA，使特定工作表的特定值合併，再抓特定值回原始檔

本帖最後由 sax868 於 2012-5-10 16:49 編輯

[attach]10803[/attach][attach]10803[/attach]

各位高手大大好:

請問以下要如何分別撰寫VBA? 因為工作表一共有一百多個，天天手動改再整理資料快哭了...拜託~救我!!!

1)
在這個檔案裡建立一個新的工作表稱”Updated Data”且資料全是"值"就好，可以不要包含原來該欄位可能有的函數嗎?
A欄值是每張工作表的 C1 (除了兩張工作表以外,其名稱為 “DATA” 及”Currency”), 且A1的值是第一張工作表的B1
B欄值是每張工作表的 C2 (除了兩張工作表以外,其名稱為 “DATA” 及”Currency”), 且B1的值是第一張工作表的B2
C欄值是每張工作表的 E1 (除了兩張工作表以外,其名稱為 “DATA” 及”Currency”), 且C1的值是第一張工作表的D1
D1到BE1的值是第一張工作表的A11到BB11
D2到BE2 以下到底部的值是每一張worksheet裡的 A12到BB12到底部 (除了兩張工作表以外,其名稱為 “DATA” 及”Currency”)

2)
該張工作表AI12到底部的值是 假設 $A12、$J12 及”固定$C$1” 三者的值與 ”Updated Data” 工作表裡A欄 D欄 M欄 三者皆相符時則值為Updated Data工作表裡的AK欄
(我有用函數寫IF(AND+AND+AND) 不過這有時靈光有時不行,也不知道為甚麼...)

感激不盡!

弱女子留

---

作者: register313    時間: 2012-5-4 16:52

回復 1# sax868

不了解 2) 之說明

1. Sub xx()
   
2. Sheets("Updated Data").Select
   
3. Cells = ""
   
4. [A1] = Sheets("AB1").[B1]:  [B1] = Sheets("AB1").[B2]:  [C1] = Sheets("AB1").[D1]
   
5. [D1:BE1] = Sheets("AB1").[A11:BB11].Value
   
6. For Each Sh In Sheets
   
7.   If Sh.Name = "Currency" Or Sh.Name = "DATA" Or Sh.Name = "Updated Data" Then Exit For
   
8.   R = 0: C = 0
   
9.   R = Sh.[A11].End(xlDown).Row: C = C + (R - 12 + 1)
   
10.   Ar = Sh.Range("A12:BB" & R).Value
    
11.   [D65536].End(xlUp).Offset(1, 0).Resize(C, 54) = Ar
    
12.   Br = Array(Sh.[C1], Sh.[C2], Sh.[E1])
    
13.   [A65536].End(xlUp).Offset(1, 0).Resize(C, 3) = Br
    
14. Next
    
15. End Sub

複製代碼

---

作者: sax868    時間: 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
拜託救我...

---

作者: Hsieh    時間: 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

複製代碼

---

作者: sax868    時間: 2012-5-6 01:03

回復 4# Hsieh

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

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

---

作者: sax868    時間: 2012-5-6 01:45

回復 5# sax868
抱歉!又是我...
我剛剛有試著把 .[A1].Resize(x, 57) = Application.Transpose(Ar)  這一行拿掉.結果開了一個新的資料表但內容是空白...

---

作者: Hsieh    時間: 2012-5-6 06:42

回復 6# sax868


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

---

作者: sax868    時間: 2012-5-6 18:54

[attach]10827[/attach][attach]10827[/attach]回復 7# Hsieh

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

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

幼稚園大班的
弱女子留

---

作者: Hsieh    時間: 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

複製代碼

---

作者: sax868    時間: 2012-5-7 22:55

本帖最後由 sax868 於 2012-5-8 12:10 編輯

[attach]10845[/attach][attach]10845[/attach]回復 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!'...

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

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

幼幼班的弱女子留:$

---

作者: sax868    時間: 2012-5-8 17:13

[attach]10861[/attach][attach]10861[/attach]回復 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)

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

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

---

作者: Hsieh    時間: 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

複製代碼

---

作者: sax868    時間: 2012-5-8 21:31

回復 12# Hsieh

感謝超級版主的幫忙! 很抱歉，我這混亂地表達沒讓您立即清楚明瞭-_-lll
'Updated Data'裡的AL欄須對應到每一張工作表的12列以下之AI欄，'Updated Data'裡的AX欄須對應到每一張工作表的12列以下之AU欄；先前動作一的VBA與現在要抓Updated Data裡的AL/AX值回每個工作表的AI/AU為二個獨立分開的VBA喔! (因為突然發現它跑了一次資料)
真不好意思，要再麻煩您了!

幼幼班表達能力不佳的
弱女子留

---

作者: Hsieh    時間: 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"對應的值
   
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

複製代碼

---

作者: sax868    時間: 2012-5-8 23:03

回復 14# Hsieh
我感動地大哭一場...
感謝超級版主的救命之恩...總算我可以從駝背又灰頭土臉到明天挺直腰桿活著走進辦公室了!!
說不盡的感激!!!

---

作者: sax868    時間: 2012-5-10 17:13

[attach]10893[/attach]回復 14# Hsieh

親愛的超級版主午安：

真不好意思! 請問在Input Data這個VBA中能不能在抓符合這三數值的同時，並需'Updated Data'AL欄或AX欄有值的才抓AL欄或AX欄的值?
With Sheets("Updated Data")
    For Each a In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))
     d(a & a.Offset(, 3) & a.Offset(, 12)) = a.Offset(, 49).Value
     d1(a & a.Offset(, 3) & a.Offset(, 12)) = a.Offset(, 37).Value

目前我遇到的狀況是符合這三數值的可能有好幾列，但只有一列是有Notes,
           舉例(請查附件)：工作表‘1008600-2013’ 因’Updated Data”裡符合這特定三數值的(1008600+500+AA) 有三行但僅其中一行有Notes, 所以VBA跑出來答案是空白

現在我能想到的是先把這些空白的手動刪除後再跑InputData VBA即可求出答案，問題是這一刪有些資料在全部更新後就找不回來了…想請問能不能麻煩超級版主幫忙多設一個條件，使:
d(a & a.Offset(, 3) & a.Offset(, 12)) = a.Offset(, 49).Value 符合外且AX欄非空格
d1(a & a.Offset(, 3) & a.Offset(, 12)) = a.Offset(, 37).Value符合外且AL欄非空格

感激不盡!!

沒招了的
弱女子留:L

---

作者: Hsieh    時間: 2012-5-10 19:49

本帖最後由 Hsieh 於 2012-5-10 19:50 編輯

回復 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

複製代碼

---

作者: sax868    時間: 2012-5-10 20:06

回復 17# Hsieh
太感激您了!!叩謝超級版主的幫忙!!


   
滿心歡喜的
弱女子留

---

作者: sax868    時間: 2012-5-12 01:23

[attach]10911[/attach]回復 17# Hsieh

親愛的超級版主晚安：

因為這個檔案連結許多檔案，擔心會有其他使用者疏忽沒存檔以致遺失資料。我想了一些方法用三腳貓功夫寫了一套把檔案自動儲存的VBA(置於Model3裡)，但是不靈光，還得麻煩請超級版主幫忙修改導正：

AutoSaveNotes:請問如何用VBA設定在每15分鐘及關檔案時(這個我不會)會自動跳出視窗要求存檔一次 (按”是”後，跑該先前設置的動作一，除了要存在工作表’Updated Data’裡(先前是另開啟一個檔案旦發覺序號會跳將來沒辦法抓回去，所以直接存在Updated Data工作表裡即可)，並自動另存檔於路徑C:\Users\JH\Downloads\，其檔名為：Notes），該存為單一工作表之名稱亦為'Updated Data'。

以上，拜託超級版主救救我!!

謝謝~

眼睛花花的
弱女子留

---

作者: Hsieh    時間: 2012-5-13 17:41

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

---

作者: sax868    時間: 2012-5-18 17:05

1. Sub SaveIt()
   
2.     Msg = MsgBox("My Dear Friend，It's been a while，please press YES to save file!" & Chr(13) _
   
3.        & "是(Y)：Save File" & Chr(13) _
   
4.        & "否(N)：You Are in Trouble." & Chr(13) _
   
5.        & "取消Cancel：Your Boss Is in Trouble.", vbYesNoCancel + 64, "Take a Break!")
   
6. '提示用戶保存當前活動文檔。
   
7.     If Msg = vbYes Then Application.Run "OutputtoUpdatedDataI" Else If Msg = vbCancel Then Exit Sub
   
8.     ActiveWorkbook.Save
   
9.     ActiveWorkbook.Worksheets("Updated Data").Copy
   
10.     ActiveWorkbook.Worksheets("Updated Data").SaveAs "D:\" & "Updated Data" & ".xlsx"
    
11.     ActiveWorkbook.Worksheets("Updated Data").SaveAs "D:\Updated Data " & Date$ & ".xlsx"
    
12.     Call runtimer '如果用戶沒有選擇取消就再次調用 Runtimer
    
13. End Sub

複製代碼

回復 20# Hsieh
搞定了!!
謝謝超級版主的指點!設定好了很好用喔!由於這個備份會把同檔案覆蓋上去，有許多幼幼班的使用者共同使用該檔，所以我也在另外設定儲存三個檔案(1.原檔、2.只有該工作表、3.只有該工作表+日期)，不過有1個小問題想麻煩請超級版處幫我解決:
1. 存'只有該工作表'在執行指令時會開起儲存後自動關閉，但'只有該工作表+日期'這個不會，請問要怎麼樣才能使2、3備份檔都在儲存後自動關閉呢? (我試了幾個方法但不靈光...有把3個檔都關掉也有3個檔都開起沒被關掉...-_-lll)

拜託您了!!
謝謝!

弱女子留

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)