123
返回列表 上一主題 發帖

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

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

Hsieh

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

2024年全勤獎章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 
13#
發表於 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喔! (因為突然發現它跑了一次資料)
真不好意思，要再麻煩您了!

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

TOP

Hsieh

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

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

sax868

帖子
37 
主題
9 
精華
0 
積分
61 
點名
0  
作業系統
Windows7 
軟體版本
office 2010 
閱讀權限
20 
性別
女 
註冊時間
2011-4-26 
最後登錄
2014-7-28 
15#
發表於 2012-5-8 23:03 | 只看該作者
回復 14# Hsieh
我感動地大哭一場...
感謝超級版主的救命之恩...總算我可以從駝背又灰頭土臉到明天挺直腰桿活著走進辦公室了!!
說不盡的感激!!!

TOP

sax868

帖子
37 
主題
9 
精華
0 
積分
61 
點名
0  
作業系統
Windows7 
軟體版本
office 2010 
閱讀權限
20 
性別
女 
註冊時間
2011-4-26 
最後登錄
2014-7-28 
16#
發表於 2012-5-10 17:13 | 只看該作者
#VALUE!.zip (131.44 KB) 回復 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

TOP

Hsieh

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

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

sax868

帖子
37 
主題
9 
精華
0 
積分
61 
點名
0  
作業系統
Windows7 
軟體版本
office 2010 
閱讀權限
20 
性別
女 
註冊時間
2011-4-26 
最後登錄
2014-7-28 
18#
發表於 2012-5-10 20:06 | 只看該作者
回復 17# Hsieh
太感激您了!!叩謝超級版主的幫忙!!


   
滿心歡喜的
弱女子留

TOP

sax868

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

親愛的超級版主晚安：

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

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

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

謝謝~

眼睛花花的
弱女子留

TOP

Hsieh

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

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

TOP

        靜思自在 : 做好事不能少我一人，做壞事不能多我一人。
123
返回列表 上一主題