sax868

#VALUE!.zip (134.69 KB)

VBA
下載次數: 5

2012-5-8 17:12

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

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

回復 12# Hsieh

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

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

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

複製代碼

sax868

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

sax868

#VALUE!.zip (131.44 KB)

下載次數: 3

2012-5-10 17:13

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

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

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


   
滿心歡喜的
弱女子留

sax868

_VALUE!2.rar (119.74 KB)

下載次數: 3

2012-5-12 01:21

回復 17# Hsieh

親愛的超級版主晚安：

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

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

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

謝謝~

眼睛花花的
弱女子留

Hsieh

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