Board logo

標題: [發問] 如何匯入EXCEL資料? [打印本頁]
作者: PJChen    時間: 2012-5-11 17:25     標題: 如何匯入EXCEL資料?

各位先進,請幫忙腦力激盪: 先謝謝了!

我的需求如下,將PI_PO資料夾的每一個檔案資料匯入PI_PO Records檔案中?用巨集程式或用函數能抓取我要的資料?(檔案已附上)
需匯入的欄位為PI/PO sheet中的合計金額及數量
1        將EXCEL表格中有PI/PO的合計金額及數量填入"PI_PO Records"檔案中
2        將EXCEL表格中只有PO的合計金額及數量填入"PI_PO Records"檔案中
   [attach]10908[/attach]
        PI_PO資料夾中檔案特性:
1        PI_PO資料夾中的所有EXCEL檔案中TOTAL欄位中的所有合計資料(包含數量/金額)
2        有些檔案KEY-IN為"TOTAL",有些是"TOTAL:"
3        EXCEL檔"TOTAL"字樣,固定在A欄
4        合計欄位數量及金額的列數則不固定,唯一固定的是數量後會有"PCS"字樣,而金額前會有"幣別"(US/USD/HKD…等)
5        EXCEL檔依客戶區分有所不同,有些檔案有"PI"與"PO" sheet,有些則只有"PO" sheet
6        PI_PO的EXCEL檔格式為 .xls  or  .xlsx(我只放了3種案例)
7        PI_PO Records的F欄File Name是特別key-in上去的(不知有沒有幫助?),通常只會有A:E欄
作者: oobird    時間: 2012-5-12 10:20

試試[attach]10912[/attach]
作者: PJChen    時間: 2012-5-14 00:10

回復 2# oobird

大人,

謝謝您幫我寫的程式,我隨手用幾個檔案作測試,其中一個檔不知為何抓取的資料會少了PO的數量及金額,你可否幫我看一下?  [attach]10936[/attach]
另外,執行過巨集的所有檔案都會詢問是否存檔(excel2003版本的PI_PO),而且我發現執行巨集過後,它會將所有在PI_PO資料夾中的檔案當成為開啟狀態(雖然我看不到有開啟),我想問以下能否修改程式?
1) 執行巨集過後,讓所有在PI_PO資料夾中的檔案自行關閉且不要詢問我是否存檔(因為以後整年度的excel會有上千個, 詢問會造成極大不便)
2) 在PI_PO Records的Excel檔中,若已執行巨集(已自動動入資料)除非我將資料Delete,否則是否可以不要讓它清除後重填?(因為我慮到整年度的資料有很多筆這樣會不執行得較快?)
  
以上麻煩您...
作者: oobird    時間: 2012-5-14 08:17

[attach]10937[/attach]
作者: PJChen    時間: 2012-5-14 17:57

回復 2# oobird
大師:

我測試了現在修改過的程式,有不少資料是抓不到的,但我檢查不出有什麼異常,我壓縮了3個檔案上傳,請幫忙看下!謝謝! [attach]10949[/attach]
作者: oobird    時間: 2012-5-14 19:49

取不到的原因是其他儲存格也有"total"字樣存在，可以換個方式。[attach]10950[/attach]
作者: PJChen    時間: 2012-5-15 13:12

回復 6# oobird
大師,
1)  程式經過第2次修正後,還有很多的資料抓取不到,我上傳5個檔案,請您幫忙看看.  [attach]10954[/attach]
2)  BCM...檔案因為有各個不同人作業,有的人會用連結,在抓取資料時會出現這樣的對話框 [attach]10955[/attach]
      詢問是否更新,因為有太多的資料是用連結的,能否在寫程式時,設定為不要更新連結?而自動進行抓取?
3)  另一種情形是BCM...檔案有些人會使用自動篩選鍵,且使用篩選鍵後又未取消,因為檔案太多無法一個一個進行檢查,是否可以在不取消篩選鍵而抓取資料?並且一樣在抓取資料後不要存檔就關閉它.
4)  在程式試RUN的過程中,發現即使只有抓取一筆資料,也要費時幾秒鐘,這樣算來若好幾千筆資料,就會有長時間的等待!請問這種情形是正常的嗎?或者能夠在程式上加以改善?
5) 可否麻煩您在程式後面註記每個語法的意思,這樣我比較能了解語法的用意,且若我需要做些小變動時比較方便.
謝謝您!
作者: oobird    時間: 2012-5-15 17:40

加上這一行可避開該對話
Application.DisplayAlerts = False
要提高效率得要下功夫，如檔案名確實填好，不要只填部份再來用程式一個個比對檔案名
資料要規範，尤其作為判斷的常數，不能有些加空格有些不加，有些有冒號有些沒有等等增加查詢困難度。
最好做做欄位都一樣，不要變來變去。
作者: PJChen    時間: 2012-5-15 21:10

回復 8# oobird
大師,

個人使用的工作表可以隨心所欲,但別人的資料很難去規定的!
我其他的問題是否能幫得上忙呢?
作者: Hsieh    時間: 2012-5-15 22:21

回復 9# PJChen

表格格式不同造成困擾，必須在所有字串中尋找會增加運行時間
[attach]10961[/attach]
作者: oobird    時間: 2012-5-15 22:31

若資料不能規範，只能隨著資料的變化不斷的改程式，那不是很辛苦？
例如妳後來的幾個檔案，QUANTITY與數量的數字不在同一欄，以QUANTITY判斷欄位，正確的數量就取不到了
同時TOTAL,QUANTITY兩個字符都存在不定數的空白鍵，模糊查找就有出錯的機會
又例如妳一樓說"TOTAL"在A欄，但又有些是在B欄的，同時B欄又有包含"TOTAL"字符的儲存格，查找時就先找到錯誤的位置了。
目前我想改變一下取得"TOTAL"的列號，該列最右是金額，倒數第四欄是數量，這樣可能會準確些
每個檔案開啟與關閉都須要時間，若檔案大開啟更慢，所以延遲個幾秒是很正常的。除非妳能規劃出固定的儲存格放置這兩個數字，這樣可以不開啟直接取值。
檔案最好用全名，否則模糊比對也可能出錯。
附件供參考
[attach]10962[/attach]
作者: PJChen    時間: 2012-5-16 18:16

回復 11# oobird
大師,

若是以檔名作搜尋比較理想,PI_PO Records的檔案中F欄中就有一個File Name專放檔名的欄位,因為A欄所設的BCM號碼我尚有其他用途,可否將取好檔名之後的檔案名稱存放在F欄(不需要改為反白)?A欄則保持原來的名稱,其他如抓取數量及金額也以F欄作為搜尋對象!
請問我該修哪裡?
作者: oobird    時間: 2012-5-16 20:48

這個要釐清一下
a欄與f欄都是妳自己輸入的嗎？就依照妳輸入的順序？
作者: PJChen    時間: 2012-5-16 21:02

回復 13# oobird
A欄是我輸入,而F欄是利用你現在新的巨集抓取的.
作者: oobird    時間: 2012-5-16 21:23

那這樣還不是要依照a欄的順序在資料夾中循環比對找出檔案全名放在f欄？
作者: PJChen    時間: 2012-5-16 21:50

回復 15# oobird
yes.
作者: PJChen    時間: 2012-5-16 21:58

回復 15# oobird
Sorry!如果前面的方式真的不理想的話,F欄就改由我自己輸入,其餘再用程式去填入?
作者: oobird    時間: 2012-5-16 23:15

[attach]10985[/attach]
作者: PJChen    時間: 2012-5-17 00:44

回復 18# oobird

我先試了抓取F欄file name的巨集,發現它只會將所有檔名抓進來而不會比對,不知哪裡出錯了?
作者: PJChen    時間: 2012-5-17 10:40

回復 10# Hsieh
版大,
我測試了您的程式,發生以下問題,所以無法執行 ,請您撥冗看下. 謝謝
1)  程式指向這行  d(Sh.Name & "數量") = b.Offset(, -1) 然後出現對話框  [attach]10986[/attach]
2)  之後出現其中一個excel檔  [attach]10988[/attach]
作者: Hsieh    時間: 2012-5-17 15:15

回復 20# PJChen

那是因為你的工作表不只是只有PI跟PO
造成TOTAL那一行找不到pcs所致
  1. Sub ex()
  2. Dim Sh As Worksheet, A As Range, Ar()
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Application.ScreenUpdating = False
  5. Application.DisplayAlerts = False
  6. fd = ThisWorkbook.Path & "\" & "PI_PO\"
  7. fs = Dir(fd & "*xls*")
  8. Do Until fs = ""
  9. With Workbooks.Open(fd & fs)
  10. n = Split(fs, " ")(0)
  11. s = InStr(n, "BCM") + 3
  12. fn = Mid(n, s)
  13.    For Each Sh In .Sheets
  14.       With Sh
  15.       If .Name <> "PO" Or .Name <> "PI" Then GoTo 10
  16.       For Each C In .Range("A:B").SpecialCells(xlCellTypeConstants)
  17.         If C Like "TOTAL*" Then Set A = C: Exit For
  18.       Next
  19.       If Not A Is Nothing Then
  20.       Set b = A.EntireRow.Find("pcs")
  21.       If Not b Is Nothing Then
  22.         d(.Name & "數量") = b.Offset(, -1)
  23.         d(.Name & "金額") = b.Offset(, 2)
  24.       End With
  25.       End If
  26.       End With
  27. 10
  28.     Next
  29.     ReDim Preserve Ar(y)
  30.     Ar(y) = Array(fn, d("PI數量"), d("PI金額"), d("PO數量"), d("PO金額"), fs)
  31.     y = y + 1
  32.     .Close
  33.     d.RemoveAll
  34. End With
  35. fs = Dir
  36. Loop
  37. Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
  38. Application.ScreenUpdating = True
  39. Application.DisplayAlerts = True
  40. End Sub
複製代碼
作者: PJChen    時間: 2012-5-17 16:31

回復 21# Hsieh
版大,
這個程式出現一個對話框 [attach]10995[/attach]
我試著去改End With的位置,但還是無法執行,請再幫忙看看!
作者: PJChen    時間: 2012-5-17 16:40

回復 19# PJChen
老大,
補充: 我試著自己key完整的檔名在F欄,然後將2012年的bcm檔案放在"2012 PI_PO"資料夾中(因為年度很多,怕run太久),然後修改程式如下,但完全不能動作!
  1. Sub get_value()
  2.     Dim a As Range, arr(1 To 5)
  3.     Application.ScreenUpdating = False    '關閉螢幕閃爍
  4.     For Each a In Range([f2], [f2].End(4))    '在f2以下的資料範圍循環
  5.         If Application.CountA(Rows(a.Row)) = 1 Then    'a:e欄已有寫入資料就跳過
  6.             Application.DisplayAlerts = False    '關閉開啟時的對話方塊
  7.             fb = ThisWorkbook.Path & "\2012 PI_PO\" & a    '從"PI_PO資料夾"取路徑
  8.             Set wk = GetObject(fb)    '背景開啟該路徑檔案
  9.             Sh = Array("PI", "PO")    '兩個工作表名
  10.             On Error Resume Next    '略過錯誤
  11.             For s = 0 To 1
  12.                 Set mysheet = wk.Sheets(Sh(s))    '工作表變量
  13.                 If Err.Number = 0 Then    '如不發生錯誤(有這個工作表)
  14.                 mysheet.AutoFilterMode = False '取消篩選
  15.                     mysheet.[a:b].Replace "TOTAL:", "TOTAL", xlWhole    '把帶分號的TOTAL改成不帶分號
  16.                     r = mysheet.[a:b].Find("TOTAL", , , 1, xlByRows).Row            '在AB兩欄尋找"TOTAL"
  17.                     c = mysheet.Cells(r, 15).End(1).Column    '取TOTAL那一行的最右欄(即金額)
  18.                     arr(1) = Split(a, " ")(0) '取f欄第一個空格以前的字串
  19.                     arr(s * 2 + 2) = mysheet.Cells(r, c - 3).Value    '取最右欄減3欄的數字
  20.                     arr(s * 2 + 3) = mysheet.Cells(r, c).Value    '取最右欄的數字
  21.                 End If
  22.                 Err.Clear    '清除錯誤
  23.             Next
  24.            Cells(a.Row, 1).Resize(1, 5) = arr   '寫入儲存格
  25.             Erase arr
  26.             wk.Close 0            '關閉打開的檔案不儲存
  27.         End If
  28.     Next
  29. End Sub
複製代碼
作者: Hsieh    時間: 2012-5-17 20:12

回復 22# PJChen
  1. Sub ex()
  2. Dim Sh As Worksheet, A As Range, Ar()
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Application.ScreenUpdating = False
  5. Application.DisplayAlerts = False
  6. fd = ThisWorkbook.Path & "\" & "PI_PO\"
  7. fs = Dir(fd & "*xls*")
  8. Do Until fs = ""
  9. With Workbooks.Open(fd & fs)
  10. n = Split(fs, " ")(0)
  11. s = InStr(n, "BCM") + 3
  12. fn = Mid(n, s)
  13.    For Each Sh In .Sheets
  14.       With Sh
  15.       If .Name <> "PO" Or .Name <> "PI" Then GoTo 10
  16.       For Each C In .Range("A:B").SpecialCells(xlCellTypeConstants)
  17.         If C Like "TOTAL*" Then Set A = C: Exit For
  18.       Next
  19.       If Not A Is Nothing Then
  20.       Set b = A.EntireRow.Find("pcs")
  21.       If Not b Is Nothing Then
  22.         d(.Name & "數量") = b.Offset(, -1)
  23.         d(.Name & "金額") = b.Offset(, 2)
  24.       End If
  25.       End If
  26.       End With
  27. 10
  28.     Next
  29.     ReDim Preserve Ar(y)
  30.     Ar(y) = Array(fn, d("PI數量"), d("PI金額"), d("PO數量"), d("PO金額"), fs)
  31.     y = y + 1
  32.     .Close
  33.     d.RemoveAll
  34. End With
  35. fs = Dir
  36. Loop
  37. Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
  38. Application.ScreenUpdating = True
  39. Application.DisplayAlerts = True
  40. End Sub
複製代碼
作者: PJChen    時間: 2012-5-17 21:05

回復 24# Hsieh
[attach]10999[/attach]
Dear 大人,

我將您修正的程式Run過後,有以下問題,
1)  我將原檔名各key-in在a及f欄,因為前面oobird提過完整的檔名比較容易抓資料,所以我就這麼作.
2)  Run完程式後,它只把A欄的完整檔名修改為我原先最初的BCM no.,其餘欄位完全未填入數值.
3)  我將Run完的結果上傳了,要麻煩您幫我看一下,我不知道發生了什麼事?
謝謝您!
作者: Hsieh    時間: 2012-5-17 21:15

回復 25# PJChen
條件應該是AND才對
If .Name <> "PO" And .Name <> "PI" Then GoTo 10
整個程式碼就是自動將檔名切割出編號A、F欄不需填寫，執行完就會秀出來了
  1. Sub get_value()
  2. Dim Sh As Worksheet, A As Range, Ar()
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Application.ScreenUpdating = False
  5. Application.DisplayAlerts = False
  6. fd = ThisWorkbook.Path & "\" & "PI_PO\"
  7. fs = Dir(fd & "*xls*")
  8. Do Until fs = ""
  9. With Workbooks.Open(fd & fs)
  10. n = Split(fs, " ")(0)
  11. s = InStr(n, "BCM") + 3
  12. fn = Mid(n, s)
  13.    For Each Sh In .Sheets
  14.       With Sh
  15.       If .Name <> "PO" And .Name <> "PI" Then GoTo 10
  16.       For Each C In .Range("A:B").SpecialCells(xlCellTypeConstants)
  17.         If C Like "TOTAL*" Then Set A = C: Exit For
  18.       Next
  19.       If Not A Is Nothing Then
  20.       Set b = A.EntireRow.Find("pcs")
  21.       If Not b Is Nothing Then
  22.         d(.Name & "數量") = b.Offset(, -1)
  23.         d(.Name & "金額") = b.Offset(, 2)
  24.       End If
  25.       End If
  26.       End With
  27. 10
  28.     Next
  29.     ReDim Preserve Ar(y)
  30.     Ar(y) = Array(fn, d("PI數量"), d("PI金額"), d("PO數量"), d("PO金額"), fs)
  31.     y = y + 1
  32.     .Close
  33.     d.RemoveAll
  34. End With
  35. fs = Dir
  36. Loop
  37. Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
  38. Application.ScreenUpdating = True
  39. Application.DisplayAlerts = True
  40. End Sub
複製代碼
作者: PJChen    時間: 2012-5-17 22:16

回復 26# Hsieh
老大,

[attach]11006[/attach]
PI_PO Records黃色底的部份無法填入數值,我猜想可能是格式不相同的問題?因為每個人的工作表格式都不同,有得救嗎?
作者: Hsieh    時間: 2012-5-17 22:51

回復 27# PJChen

工作表名稱不符多了空白鍵
  1. Sub get_value()
  2. Dim Sh As Worksheet, A As Range, Ar(), B As Range, B1 As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Application.ScreenUpdating = False
  5. Application.DisplayAlerts = False
  6. fd = ThisWorkbook.Path & "\" & "PI_PO\"
  7. fs = Dir(fd & "*xls*")
  8. Do Until fs = ""
  9. With Workbooks.Open(fd & fs)
  10. n = Split(fs, " ")(0)
  11. s = InStr(n, "BCM") + 3
  12. fn = Mid(n, s)
  13.    For Each Sh In .Sheets
  14.       With Sh
  15.       If Trim(.Name) <> "PO" And Trim(.Name) <> "PI" Then GoTo 10
  16.       For Each C In .Range("A:B").SpecialCells(xlCellTypeConstants)
  17.         If C Like "TOTAL*" Then Set A = C: Exit For
  18.       Next
  19.       If Not A Is Nothing Then
  20.       Set B = A.EntireRow.Find("pcs")
  21.       Set B1 = A.EntireRow.Find("*", after:=B)
  22.       
  23.       If Not B Is Nothing Then
  24.         d(Trim(.Name) & "數量") = B.Offset(, -1)
  25.         c1 = A.EntireRow.Find("*", after:=B1)
  26.         d(Trim(.Name) & "金額") = c1
  27.       End If
  28.       End If
  29.       Set A = Nothing
  30.       End With
  31. 10
  32.     Next
  33.     ReDim Preserve Ar(y)
  34.     Ar(y) = Array(fn, d("PI數量"), d("PI金額"), d("PO數量"), d("PO金額"), fs)
  35.     y = y + 1
  36.     .Close
  37.     d.RemoveAll
  38. End With
  39. fs = Dir
  40. Loop
  41. Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
  42. Application.ScreenUpdating = True
  43. Application.DisplayAlerts = True
  44. End Sub
複製代碼
作者: PJChen    時間: 2012-5-18 10:11

回復 18# oobird
老大,不好意思這是回覆給你的,我按錯樓層,我想你應該沒收到,我將前2次做個整理.
1) 我先試了抓取F欄file name的巨集,發現它只會將所有檔名抓進來而不會比對.
2) 我試著自己key完整的檔名在F欄,然後將2012年的bcm檔案放在"2012 PI_PO"資料夾中(因為年度很多,怕run太久),然後修改程式如下,但完全不能動作!
  1. Sub get_value()
  2.     Dim a As Range, arr(1 To 5)
  3.     Application.ScreenUpdating = False    '關閉螢幕閃爍
  4.     For Each a In Range([f2], [f2].End(4))    '在f2以下的資料範圍循環
  5.         If Application.CountA(Rows(a.Row)) = 1 Then    'a:e欄已有寫入資料就跳過
  6.             Application.DisplayAlerts = False    '關閉開啟時的對話方塊
  7.             fb = ThisWorkbook.Path & "\2012 PI_PO\" & a    '從"PI_PO資料夾"取路徑
  8.             Set wk = GetObject(fb)    '背景開啟該路徑檔案
  9.             Sh = Array("PI", "PO")    '兩個工作表名
  10.             On Error Resume Next    '略過錯誤
  11.             For s = 0 To 1
  12.                 Set mysheet = wk.Sheets(Sh(s))    '工作表變量
  13.                 If Err.Number = 0 Then    '如不發生錯誤(有這個工作表)
  14.                 mysheet.AutoFilterMode = False '取消篩選
  15.                     mysheet.[a:b].Replace "TOTAL:", "TOTAL", xlWhole    '把帶分號的TOTAL改成不帶分號
  16.                     r = mysheet.[a:b].Find("TOTAL", , , 1, xlByRows).Row            '在AB兩欄尋找"TOTAL"
  17.                     c = mysheet.Cells(r, 15).End(1).Column    '取TOTAL那一行的最右欄(即金額)
  18.                     arr(1) = Split(a, " ")(0) '取f欄第一個空格以前的字串
  19.                     arr(s * 2 + 2) = mysheet.Cells(r, c - 3).Value    '取最右欄減3欄的數字
  20.                     arr(s * 2 + 3) = mysheet.Cells(r, c).Value    '取最右欄的數字
  21.                 End If
  22.                 Err.Clear    '清除錯誤
  23.             Next
  24.            Cells(a.Row, 1).Resize(1, 5) = arr   '寫入儲存格
  25.             Erase arr
  26.             wk.Close 0            '關閉打開的檔案不儲存
  27.         End If
  28.     Next
  29. End Sub
複製代碼
作者: PJChen    時間: 2012-5-18 10:37

回復 28# Hsieh
版大,
改成這樣目前無法執行, 出現了這樣的訊息: [attach]11014[/attach]
作者: oobird    時間: 2012-5-18 10:48

請注意這個
If Application.CountA(Rows(a.Row)) = 1 Then    'a:e欄已有寫入資料就跳過
這行限制了只有F欄有數據才執行，A~E不要有任何東西。
作者: PJChen    時間: 2012-5-18 12:05

回復 31# oobird

老大,
我重新RUN一次,有三個檔案會出錯,我上傳了.再麻煩您!
[attach]11016[/attach]
作者: oobird    時間: 2012-5-18 12:36

PO工作表表名有問題，重新命名就可以了
也許多了空白格，也許是全型的我沒很注意。[attach]11017[/attach]
作者: PJChen    時間: 2012-5-18 12:54

回復 28# Hsieh
大人,
以下的程式執行時,若發現資料有連結,會一直出現對話框,可以讓它自選擇不更新而繼續執行嗎?
  1. Sub get_value()
  2. Dim Sh As Worksheet, a As Range, Ar(), B As Range, B1 As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Application.ScreenUpdating = False
  5. Application.DisplayAlerts = False
  6. fd = ThisWorkbook.Path & "\" & "2011 PI_PO\"
  7. fs = Dir(fd & "*xls*")
  8. Do Until fs = ""
  9. With Workbooks.Open(fd & fs)
  10. n = Split(fs, " ")(0)
  11. s = InStr(n, "BCM") + 3
  12. fn = Mid(n, s)
  13.    For Each Sh In .Sheets
  14.       With Sh
  15.       If Trim(.Name) <> "PO" And Trim(.Name) <> "PI" Then GoTo 10
  16.       For Each c In .Range("A:B").SpecialCells(xlCellTypeConstants)
  17.         If c Like "TOTAL*" Then Set a = c: Exit For
  18.       Next
  19.       If Not a Is Nothing Then
  20.       Set B = a.EntireRow.Find("pcs")
  21.       Set B1 = a.EntireRow.Find("*", after:=B)
  22.       
  23.       If Not B Is Nothing Then
  24.         d(Trim(.Name) & "數量") = B.Offset(, -1)
  25.         c1 = a.EntireRow.Find("*", after:=B1)
  26.         d(Trim(.Name) & "金額") = c1
  27.       End If
  28.       End If
  29.       Set a = Nothing
  30.       End With
  31. 10
  32.     Next
  33.     ReDim Preserve Ar(y)
  34.     Ar(y) = Array(fn, d("PI數量"), d("PI金額"), d("PO數量"), d("PO金額"), fs)
  35.     y = y + 1
  36.     .Close
  37.     d.RemoveAll
  38. End With
  39. fs = Dir
  40. Loop
  41. Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
  42. Application.ScreenUpdating = True
  43. Application.DisplayAlerts = True
  44. End Sub
複製代碼
作者: Hsieh    時間: 2012-5-18 14:06

回復 34# PJChen
  1. Sub get_value()
  2. Dim Sh As Worksheet, a As Range, Ar(), B As Range, B1 As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Application.ScreenUpdating = False
  5. Application.DisplayAlerts = False
  6. fd = ThisWorkbook.Path & "\" & "2011 PI_PO\"
  7. fs = Dir(fd & "*xls*")
  8. Do Until fs = ""
  9. With Workbooks.Open(Filename:=fd & fs, UpdateLinks:=False)
  10. n = Split(fs, " ")(0)
  11. s = InStr(n, "BCM") + 3
  12. fn = Mid(n, s)
  13.    For Each Sh In .Sheets
  14.       With Sh
  15.       If Trim(.Name) <> "PO" And Trim(.Name) <> "PI" Then GoTo 10
  16.       For Each c In .Range("A:B").SpecialCells(xlCellTypeConstants)
  17.         If c Like "TOTAL*" Then Set a = c: Exit For
  18.       Next
  19.       If Not a Is Nothing Then
  20.       Set B = a.EntireRow.Find("pcs")
  21.       Set B1 = a.EntireRow.Find("*", after:=B)
  22.       
  23.       If Not B Is Nothing Then
  24.         d(Trim(.Name) & "數量") = B.Offset(, -1)
  25.         c1 = a.EntireRow.Find("*", after:=B1)
  26.         d(Trim(.Name) & "金額") = c1
  27.       End If
  28.       End If
  29.       Set a = Nothing
  30.       End With
  31. 10
  32.     Next
  33.     ReDim Preserve Ar(y)
  34.     Ar(y) = Array(fn, d("PI數量"), d("PI金額"), d("PO數量"), d("PO金額"), fs)
  35.     y = y + 1
  36.     .Close
  37.     d.RemoveAll
  38. End With
  39. fs = Dir
  40. Loop
  41. Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
  42. Application.ScreenUpdating = True
  43. Application.DisplayAlerts = True
  44. End Sub
複製代碼
作者: PJChen    時間: 2012-5-18 14:11

回復 33# oobird
老大,
我將去年的PI/PO拿來測試,發現還是會一直出現對話框,詢問是否更新連結, 雖然程式中有這句話 Application.DisplayAlerts = False
  1. Sub get_value_F()
  2.     Dim a As Range, arr(1 To 5)
  3.     Application.ScreenUpdating = False    '關閉螢幕閃爍
  4.     For Each a In Range([f2], [f2].End(4))    '在f2以下的資料範圍循環
  5.         If Application.CountA(Rows(a.Row)) = 1 Then    'a:e欄已有寫入資料就跳過
  6.             Application.DisplayAlerts = False    '關閉開啟時的對話方塊
  7.             fb = ThisWorkbook.Path & "\2011 PI_PO\" & a    '從"PI_PO資料夾"取路徑
  8.             Set wk = GetObject(fb)    '背景開啟該路徑檔案
  9.             Sh = Array("PI", "PO")    '兩個工作表名
  10.             On Error Resume Next    '略過錯誤
  11.             For s = 0 To 1
  12.                 Set mysheet = wk.Sheets(Sh(s))    '工作表變量
  13.                 If Err.Number = 0 Then    '如不發生錯誤(有這個工作表)
  14.                 mysheet.AutoFilterMode = False '取消篩選
  15.                     mysheet.[a:b].Replace "TOTAL:", "TOTAL", xlWhole    '把帶分號的TOTAL改成不帶分號
  16.                     r = mysheet.[a:b].Find("TOTAL", , , 1, xlByRows).Row    '在AB兩欄尋找"TOTAL"
  17.                     c = mysheet.Cells(r, 15).End(1).Column    '取TOTAL那一行的最右欄(即金額)
  18.                     arr(1) = Split(a, " ")(0) '取f欄第一個空格以前的字串
  19.                     arr(s * 2 + 2) = mysheet.Cells(r, c - 3).Value    '取最右欄減3欄的數字
  20.                     arr(s * 2 + 3) = mysheet.Cells(r, c).Value    '取最右欄的數字
  21.                 End If
  22.                 Err.Clear    '清除錯誤
  23.             Next
  24.            Cells(a.Row, 1).Resize(1, 5) = arr   '寫入儲存格
  25.             Erase arr
  26.             wk.Close 0            '關閉打開的檔案不儲存
  27.         End If
  28.     Next
  29. End Sub
複製代碼
作者: PJChen    時間: 2012-5-18 14:46

回復 35# Hsieh
大人,

詢問更新的對話框不再出現了,但出現了新的對話框如下,我將幾個檔案上傳,麻煩你.
[attach]11022[/attach]
[attach]11023[/attach]
作者: oobird    時間: 2012-5-18 22:18

本帖最後由 oobird 於 2012-5-18 22:23 編輯

這幾個檔案的問題是兩欄都有"TOTAL"
For Each c In .Range("A:B").SpecialCells(xlCellTypeConstants)
改成 For Each c In .Range("A:A").SpecialCells(xlCellTypeConstants)
還是老問題，B欄也有"TOTAL",而且在前面，導致錯誤判斷
改成只在A欄尋找, 但妳要保証"TOTAL"是在A欄
至於還是會出現對話方塊的問題，沒實際碰到不知是什麼情況。
作者: PJChen    時間: 2012-5-18 22:40

回復 38# oobird
回復 35# Hsieh
老大,請問你是否回答我第37樓的問題?若是的話:
歸究起來是檔案太多不同格式所造成的問題,若是TOTAL的問題,我想很多欄位都會用這個字,若我統一只採用"TOTAL:"(是有冒號的),則以下這2個程式上我應該如何修改?該它只在看到"TOTAL:"的情形下才作動作?(二個程式各有它好用用的地方,我都想修改它)
  1. Sub get_value()
  2. Dim Sh As Worksheet, a As Range, Ar(), B As Range, B1 As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Application.ScreenUpdating = False
  5. Application.DisplayAlerts = False
  6. fd = ThisWorkbook.Path & "\" & "2011 PI_PO\"
  7. fs = Dir(fd & "*xls*")
  8. Do Until fs = ""
  9. With Workbooks.Open(Filename:=fd & fs, UpdateLinks:=False)
  10. n = Split(fs, " ")(0)
  11. s = InStr(n, "BCM") + 3
  12. fn = Mid(n, s)
  13.    For Each Sh In .Sheets
  14.       With Sh
  15.       If Trim(.Name) <> "PO" And Trim(.Name) <> "PI" Then GoTo 10
  16.       For Each c In .Range("A:B").SpecialCells(xlCellTypeConstants)
  17.         If c Like "TOTAL*" Then Set a = c: Exit For
  18.       Next
  19.       If Not a Is Nothing Then
  20.       Set B = a.EntireRow.Find("pcs")
  21.       Set B1 = a.EntireRow.Find("*", after:=B)
  22.       
  23.       If Not B Is Nothing Then
  24.         d(Trim(.Name) & "數量") = B.Offset(, -1)
  25.         c1 = a.EntireRow.Find("*", after:=B1)
  26.         d(Trim(.Name) & "金額") = c1
  27.       End If
  28.       End If
  29.       Set a = Nothing
  30.       End With
  31. 10
  32.     Next
  33.     ReDim Preserve Ar(y)
  34.     Ar(y) = Array(fn, d("PI數量"), d("PI金額"), d("PO數量"), d("PO金額"), fs)
  35.     y = y + 1
  36.     .Close
  37.     d.RemoveAll
  38. End With
  39. fs = Dir
  40. Loop
  41. Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
  42. Application.ScreenUpdating = True
  43. Application.DisplayAlerts = True
  44. End Sub
複製代碼
  1. Sub get_value_F()
  2.     Dim a As Range, arr(1 To 5)
  3.     Application.ScreenUpdating = False    '關閉螢幕閃爍
  4.     For Each a In Range([f2], [f2].End(4))    '在f2以下的資料範圍循環
  5.         If Application.CountA(Rows(a.Row)) = 1 Then    'a:e欄已有寫入資料就跳過
  6.             Application.DisplayAlerts = False    '關閉開啟時的對話方塊
  7.             fb = ThisWorkbook.Path & "\2011 PI_PO\" & a    '從"PI_PO資料夾"取路徑
  8.             Set wk = GetObject(fb)    '背景開啟該路徑檔案
  9.             Sh = Array("PI", "PO")    '兩個工作表名
  10.             On Error Resume Next    '略過錯誤
  11.             For s = 0 To 1
  12.                 Set mysheet = wk.Sheets(Sh(s))    '工作表變量
  13.                 If Err.Number = 0 Then    '如不發生錯誤(有這個工作表)
  14.                 mysheet.AutoFilterMode = False '取消篩選
  15.                     mysheet.[a:b].Replace "TOTAL:", "TOTAL", xlWhole    '把帶分號的TOTAL改成不帶分號
  16.                     r = mysheet.[a:b].Find("TOTAL", , , 1, xlByRows).Row    '在AB兩欄尋找"TOTAL"
  17.                     c = mysheet.Cells(r, 15).End(1).Column    '取TOTAL那一行的最右欄(即金額)
  18.                     arr(1) = Split(a, " ")(0) '取f欄第一個空格以前的字串
  19.                     arr(s * 2 + 2) = mysheet.Cells(r, c - 3).Value    '取最右欄減3欄的數字
  20.                     arr(s * 2 + 3) = mysheet.Cells(r, c).Value    '取最右欄的數字
  21.                 End If
  22.                 Err.Clear    '清除錯誤
  23.             Next
  24.            Cells(a.Row, 1).Resize(1, 5) = arr   '寫入儲存格
  25.             Erase arr
  26.             wk.Close 0            '關閉打開的檔案不儲存
  27.         End If
  28.     Next
  29. End Sub
複製代碼
作者: Hsieh    時間: 2012-5-18 23:36

回復 39# PJChen
一列中同時存在TOTAL與PCS作為判斷標準
  1. Sub get_value()
  2. Dim Sh As Worksheet, a As Range, Ar(), B As Range, B1 As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Application.ScreenUpdating = False
  5. Application.DisplayAlerts = False
  6. fd = ThisWorkbook.Path & "\" & "PI_PO\"
  7. fs = Dir(fd & "*xls*")
  8. Do Until fs = ""
  9. With Workbooks.Open(Filename:=fd & fs, UpdateLinks:=False)
  10. n = Split(fs, " ")(0)
  11. s = InStr(n, "BCM") + 3
  12. fn = Mid(n, s)
  13.    For Each Sh In .Sheets
  14.       With Sh
  15.       If Trim(.Name) <> "PO" And Trim(.Name) <> "PI" Then GoTo 10
  16.       ay = .UsedRange.Value
  17.       For i = 1 To UBound(ay)
  18.          mystr = UCase(Join(Application.Index(ay, i)))
  19.          If InStr(mystr, "TOTAL") > 0 And InStr(mystr, "PCS") > 0 Then
  20.             For j = 1 To UBound(ay, 2)
  21.                If ay(i, j) = "PCS" Then d(Trim(.Name) & "數量") = ay(i, j - 1): yn = True
  22.                If IsNumeric(ay(i, j)) And yn = True Then d(Trim(.Name) & "金額") = ay(i, j): yn = False: Exit For
  23.             Next
  24.          End If
  25.       Next
  26. 20
  27.       End With
  28. 10
  29.     Next
  30.     ReDim Preserve Ar(y)
  31.     Ar(y) = Array(fn, d("PI數量"), d("PI金額"), d("PO數量"), d("PO金額"), fs)
  32.     y = y + 1
  33.     .Close
  34.     d.RemoveAll
  35. End With
  36. fs = Dir
  37. Loop
  38. Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
  39. Application.ScreenUpdating = True
  40. Application.DisplayAlerts = True
  41. End Sub
複製代碼
作者: PJChen    時間: 2012-5-19 00:36

回復 40# Hsieh
大人,
檔案中金額或數量若出現        錯誤訊息,例:#REF!,如何讓它依然填在PI_PO Records檔案中?我事後再去查看問題就好了,否則程會停滯不執行!

回復 38# oobird
oobird大大:
因為您寫的程式完全不會顯示正在run哪一筆,所以每當出現以下的對話框,我真不知是什麼問題?且因為有很多檔案有這種情形(我無法得知是哪一個?),能否就只是讓程式自動選擇不要更新且自動往下執行?否則程式在run時必須一直等在電腦前按"不更新"!

[attach]11057[/attach]
作者: oobird    時間: 2012-5-19 09:30

Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
這兩行一起用試試
作者: Hsieh    時間: 2012-5-19 14:48

本帖最後由 Hsieh 於 2012-5-19 14:49 編輯

回復 41# PJChen
  1. Sub get_value()
  2. Dim Sh As Worksheet, a As Range, Ar(), B As Range, B1 As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Application.ScreenUpdating = False
  5. Application.DisplayAlerts = False
  6. fd = ThisWorkbook.Path & "\" & "PI_PO\"
  7. fs = Dir(fd & "*xls*")
  8. Do Until fs = ""
  9. With Workbooks.Open(Filename:=fd & fs, UpdateLinks:=False)
  10. n = Split(fs, " ")(0)
  11. s = InStr(n, "BCM") + 3
  12. fn = Mid(n, s)
  13.    For Each Sh In .Sheets
  14.       With Sh
  15.       If Trim(.Name) <> "PO" And Trim(.Name) <> "PI" Then GoTo 10
  16.       ay = .UsedRange.Value
  17.       For i = 1 To UBound(ay)
  18.          mystr = ""
  19.          For j1 = 1 To UBound(ay, 2)
  20.             mystr = IIf(mystr = "", UCase(Trim(.Cells(i, j1).Text)), mystr & Chr(10) & UCase(Trim(.Cells(i, j1).Text)))
  21.          Next
  22.          If Trim(Replace(mystr, Chr(10), "")) Like "TOTAL*PCS?*" Then
  23.          ak = Split(mystr, "PCS")
  24.          ax = Split(Trim(ak(0)), Chr(10))
  25.          ap = Split(Trim(ak(1)), Chr(10))
  26.                d(Trim(.Name) & "數量") = ax(UBound(ax) - 1)
  27.                d(Trim(.Name) & "金額") = ap(2)
  28.                Exit For
  29.          End If
  30.       Next
  31.       End With
  32. 10
  33.     Next
  34.     ReDim Preserve Ar(y)
  35.     Ar(y) = Array(fn, d("PI數量"), d("PI金額"), d("PO數量"), d("PO金額"), fs)
  36.     y = y + 1
  37.     .Close
  38.     d.RemoveAll
  39. End With
  40. fs = Dir
  41. Loop
  42. Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
  43. Application.ScreenUpdating = True
  44. Application.DisplayAlerts = True
  45. End Sub
複製代碼
作者: PJChen    時間: 2012-5-21 11:51

回復 42# oobird

大大,
果然不會再出現詢問的對話框了.
作者: PJChen    時間: 2012-5-21 12:04

回復 43# Hsieh

老大,

40樓的程式抓到的資料比較完整.
這次修改的雖然可以將#REF! 這種儲存格的資料依然填入PI_PO Records中不會再停滯不執行,但有其他以往抓得到的資料現在卻無法抓到!
能否以40樓的程式為基礎,只要小小的修改不會因為亂碼的數值?(如前面所提#REF! )而停滯不執行?



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