Hsieh

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

回復 24# Hsieh
VBA TEST 5-answer 4_Hsieh.zip (213.25 KB)

下載次數: 3

2012-5-17 20:58

Dear 大人,

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

Hsieh

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

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

複製代碼

PJChen

回復 21# Hsieh
版大,
這個程式出現一個對話框

下載 (13.4 KB)

2012-5-17 16:30

我試著去改End With的位置,但還是無法執行,請再幫忙看看!

Hsieh

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

回復 10# Hsieh
版大,
我測試了您的程式,發生以下問題,所以無法執行 ,請您撥冗看下. 謝謝
1)  程式指向這行  d(Sh.Name & "數量") = b.Offset(, -1) 然後出現對話框  

下載 (17.29 KB)

2012-5-17 10:33

2)  之後出現其中一個excel檔   BCM120105-10 CF blank cap-PO#3310 (出加拿大).zip (23.71 KB)

下載次數: 3

2012-5-17 10:40

PJChen

回復 18# oobird

我先試了抓取F欄file name的巨集,發現它只會將所有檔名抓進來而不會比對,不知哪裡出錯了?

oobird

PI_PO Records.rar (34.25 KB)

下載次數: 3

2012-5-16 23:15

PJChen

回復 15# oobird
Sorry!如果前面的方式真的不理想的話,F欄就改由我自己輸入,其餘再用程式去填入?