12345
返回列表 上一主題 發帖

[發問] 如何匯入EXCEL資料?

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
1# 跳轉到 » 正序看帖
打印
tT
發表於 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"檔案中
    VBA TEST 5.zip (107.4 KB)
        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欄
收藏 分享

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
45#
發表於 2012-5-21 12:04 | 只看該作者
回復 43# Hsieh

老大,

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

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
44#
發表於 2012-5-21 11:51 | 只看該作者
回復 42# oobird

大大,
果然不會再出現詢問的對話框了.

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
43#
發表於 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
複製代碼
學海無涯_不恥下問

TOP

oobird
　頭銜: 街友一族

超級版主Rank: 8Rank: 8

帖子
1572 
主題
16 
精華
2 
積分
1521 
點名
0  
作業系統
xp 
軟體版本
office 2003 
閱讀權限
150 
性別
男 
註冊時間
2010-5-1 
最後登錄
2016-1-13 

論壇貢獻勳章
42#
發表於 2012-5-19 09:30 | 只看該作者
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
這兩行一起用試試

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
41#
發表於 2012-5-19 00:36 | 只看該作者
回復 40# Hsieh
大人,
檔案中金額或數量若出現        錯誤訊息,例:#REF!,如何讓它依然填在PI_PO Records檔案中?我事後再去查看問題就好了,否則程會停滯不執行!

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

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
40#
發表於 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
複製代碼
學海無涯_不恥下問

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
39#
發表於 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
複製代碼

TOP

oobird
　頭銜: 街友一族

超級版主Rank: 8Rank: 8

帖子
1572 
主題
16 
精華
2 
積分
1521 
點名
0  
作業系統
xp 
軟體版本
office 2003 
閱讀權限
150 
性別
男 
註冊時間
2010-5-1 
最後登錄
2016-1-13 

論壇貢獻勳章
38#
發表於 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欄
至於還是會出現對話方塊的問題，沒實際碰到不知是什麼情況。

TOP

PJChen
　暱稱: PJ

大學生Rank: 4

帖子
913 
主題
150 
精華
0 
積分
1089 
點名
0  
作業系統
win10 
軟體版本
office 2019 
閱讀權限
50 
性別
女 
註冊時間
2011-8-28 
最後登錄
2023-7-19 

論壇榮譽勳章論壇贊助勳章
37#
發表於 2012-5-18 14:46 | 只看該作者
回復 35# Hsieh
大人,

詢問更新的對話框不再出現了,但出現了新的對話框如下,我將幾個檔案上傳,麻煩你.
型態不符.jpg
VBA TEST 5-answer 4_Hsieh.zip (127.44 KB)

TOP

        靜思自在 : 滴水成河。粒米成蘿，勿輕己靈，勿以善小而不為。
12345
返回列表 上一主題