如何匯入EXCEL資料? - Excel程式區

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

論壇貢獻勳章

31^# 跳轉到 »

發表於 2012-5-18 10:48 | 只看該作者

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

　暱稱: PJ

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

論壇榮譽勳章論壇贊助勳章

32^#

發表於 2012-5-18 12:05 | 只看該作者

回復 31# oobird

老大,
我重新RUN一次,有三個檔案會出錯,我上傳了.再麻煩您!

VBA TEST 5-answer 5.zip (120.16 KB)

oobird

　頭銜: 街友一族

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

論壇貢獻勳章

33^#

發表於 2012-5-18 12:36 | 只看該作者

PO工作表表名有問題，重新命名就可以了
也許多了空白格，也許是全型的我沒很注意。

VBA TEST 5-answer 5.rar (122.42 KB)

　暱稱: PJ

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

論壇榮譽勳章論壇贊助勳章

34^#

發表於 2012-5-18 12:54 | 只看該作者

回復 28# Hsieh
大人,
以下的程式執行時,若發現資料有連結,會一直出現對話框,可以讓它自選擇不更新而繼續執行嗎?

Sub get_value()
Dim Sh As Worksheet, a As Range, Ar(), B As Range, B1 As Range
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
fd = ThisWorkbook.Path & "\" & "2011 PI_PO\"
fs = Dir(fd & "*xls*")
Do Until fs = ""
With Workbooks.Open(fd & fs)
n = Split(fs, " ")(0)
s = InStr(n, "BCM") + 3
fn = Mid(n, s)
For Each Sh In .Sheets
With Sh
If Trim(.Name) <> "PO" And Trim(.Name) <> "PI" Then GoTo 10
For Each c In .Range("A:B").SpecialCells(xlCellTypeConstants)
If c Like "TOTAL*" Then Set a = c: Exit For
Next
If Not a Is Nothing Then
Set B = a.EntireRow.Find("pcs")
Set B1 = a.EntireRow.Find("*", after:=B)
If Not B Is Nothing Then
d(Trim(.Name) & "數量") = B.Offset(, -1)
c1 = a.EntireRow.Find("*", after:=B1)
d(Trim(.Name) & "金額") = c1
End If
End If
Set a = Nothing
End With
10
Next
ReDim Preserve Ar(y)
Ar(y) = Array(fn, d("PI數量"), d("PI金額"), d("PO數量"), d("PO金額"), fs)
y = y + 1
.Close
d.RemoveAll
End With
fs = Dir
Loop
Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

複製代碼

Hsieh

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

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

35^#

發表於 2012-5-18 14:06 | 只看該作者

回復 34# PJChen

Sub get_value()
Dim Sh As Worksheet, a As Range, Ar(), B As Range, B1 As Range
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
fd = ThisWorkbook.Path & "\" & "2011 PI_PO\"
fs = Dir(fd & "*xls*")
Do Until fs = ""
With Workbooks.Open(Filename:=fd & fs, UpdateLinks:=False)
n = Split(fs, " ")(0)
s = InStr(n, "BCM") + 3
fn = Mid(n, s)
For Each Sh In .Sheets
With Sh
If Trim(.Name) <> "PO" And Trim(.Name) <> "PI" Then GoTo 10
For Each c In .Range("A:B").SpecialCells(xlCellTypeConstants)
If c Like "TOTAL*" Then Set a = c: Exit For
Next
If Not a Is Nothing Then
Set B = a.EntireRow.Find("pcs")
Set B1 = a.EntireRow.Find("*", after:=B)
If Not B Is Nothing Then
d(Trim(.Name) & "數量") = B.Offset(, -1)
c1 = a.EntireRow.Find("*", after:=B1)
d(Trim(.Name) & "金額") = c1
End If
End If
Set a = Nothing
End With
10
Next
ReDim Preserve Ar(y)
Ar(y) = Array(fn, d("PI數量"), d("PI金額"), d("PO數量"), d("PO金額"), fs)
y = y + 1
.Close
d.RemoveAll
End With
fs = Dir
Loop
Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

複製代碼

學海無涯_不恥下問

　暱稱: PJ

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

論壇榮譽勳章論壇贊助勳章

36^#

發表於 2012-5-18 14:11 | 只看該作者

回復 33# oobird
老大,
我將去年的PI/PO拿來測試,發現還是會一直出現對話框,詢問是否更新連結, 雖然程式中有這句話 Application.DisplayAlerts = False

Sub get_value_F()
Dim a As Range, arr(1 To 5)
Application.ScreenUpdating = False '關閉螢幕閃爍
For Each a In Range([f2], [f2].End(4)) '在f2以下的資料範圍循環
If Application.CountA(Rows(a.Row)) = 1 Then 'a:e欄已有寫入資料就跳過
Application.DisplayAlerts = False '關閉開啟時的對話方塊
fb = ThisWorkbook.Path & "\2011 PI_PO\" & a '從"PI_PO資料夾"取路徑
Set wk = GetObject(fb) '背景開啟該路徑檔案
Sh = Array("PI", "PO") '兩個工作表名
On Error Resume Next '略過錯誤
For s = 0 To 1
Set mysheet = wk.Sheets(Sh(s)) '工作表變量
If Err.Number = 0 Then '如不發生錯誤(有這個工作表)
mysheet.AutoFilterMode = False '取消篩選
mysheet.[a:b].Replace "TOTAL:", "TOTAL", xlWhole '把帶分號的TOTAL改成不帶分號
r = mysheet.[a:b].Find("TOTAL", , , 1, xlByRows).Row '在AB兩欄尋找"TOTAL"
c = mysheet.Cells(r, 15).End(1).Column '取TOTAL那一行的最右欄(即金額)
arr(1) = Split(a, " ")(0) '取f欄第一個空格以前的字串
arr(s * 2 + 2) = mysheet.Cells(r, c - 3).Value '取最右欄減3欄的數字
arr(s * 2 + 3) = mysheet.Cells(r, c).Value '取最右欄的數字
End If
Err.Clear '清除錯誤
Next
Cells(a.Row, 1).Resize(1, 5) = arr '寫入儲存格
Erase arr
wk.Close 0 '關閉打開的檔案不儲存
End If
Next
End Sub

複製代碼

　暱稱: PJ

帖子: 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)

oobird

　頭銜: 街友一族

帖子: 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欄
至於還是會出現對話方塊的問題，沒實際碰到不知是什麼情況。

　暱稱: PJ

帖子: 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:"的情形下才作動作?(二個程式各有它好用用的地方,我都想修改它)

Sub get_value()
Dim Sh As Worksheet, a As Range, Ar(), B As Range, B1 As Range
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
fd = ThisWorkbook.Path & "\" & "2011 PI_PO\"
fs = Dir(fd & "*xls*")
Do Until fs = ""
With Workbooks.Open(Filename:=fd & fs, UpdateLinks:=False)
n = Split(fs, " ")(0)
s = InStr(n, "BCM") + 3
fn = Mid(n, s)
For Each Sh In .Sheets
With Sh
If Trim(.Name) <> "PO" And Trim(.Name) <> "PI" Then GoTo 10
For Each c In .Range("A:B").SpecialCells(xlCellTypeConstants)
If c Like "TOTAL*" Then Set a = c: Exit For
Next
If Not a Is Nothing Then
Set B = a.EntireRow.Find("pcs")
Set B1 = a.EntireRow.Find("*", after:=B)
If Not B Is Nothing Then
d(Trim(.Name) & "數量") = B.Offset(, -1)
c1 = a.EntireRow.Find("*", after:=B1)
d(Trim(.Name) & "金額") = c1
End If
End If
Set a = Nothing
End With
10
Next
ReDim Preserve Ar(y)
Ar(y) = Array(fn, d("PI數量"), d("PI金額"), d("PO數量"), d("PO金額"), fs)
y = y + 1
.Close
d.RemoveAll
End With
fs = Dir
Loop
Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

複製代碼

Sub get_value_F()
Dim a As Range, arr(1 To 5)
Application.ScreenUpdating = False '關閉螢幕閃爍
For Each a In Range([f2], [f2].End(4)) '在f2以下的資料範圍循環
If Application.CountA(Rows(a.Row)) = 1 Then 'a:e欄已有寫入資料就跳過
Application.DisplayAlerts = False '關閉開啟時的對話方塊
fb = ThisWorkbook.Path & "\2011 PI_PO\" & a '從"PI_PO資料夾"取路徑
Set wk = GetObject(fb) '背景開啟該路徑檔案
Sh = Array("PI", "PO") '兩個工作表名
On Error Resume Next '略過錯誤
For s = 0 To 1
Set mysheet = wk.Sheets(Sh(s)) '工作表變量
If Err.Number = 0 Then '如不發生錯誤(有這個工作表)
mysheet.AutoFilterMode = False '取消篩選
mysheet.[a:b].Replace "TOTAL:", "TOTAL", xlWhole '把帶分號的TOTAL改成不帶分號
r = mysheet.[a:b].Find("TOTAL", , , 1, xlByRows).Row '在AB兩欄尋找"TOTAL"
c = mysheet.Cells(r, 15).End(1).Column '取TOTAL那一行的最右欄(即金額)
arr(1) = Split(a, " ")(0) '取f欄第一個空格以前的字串
arr(s * 2 + 2) = mysheet.Cells(r, c - 3).Value '取最右欄減3欄的數字
arr(s * 2 + 3) = mysheet.Cells(r, c).Value '取最右欄的數字
End If
Err.Clear '清除錯誤
Next
Cells(a.Row, 1).Resize(1, 5) = arr '寫入儲存格
Erase arr
wk.Close 0 '關閉打開的檔案不儲存
End If
Next
End Sub

複製代碼

Hsieh

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

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

40^#

發表於 2012-5-18 23:36 | 只看該作者

回復 39# PJChen
一列中同時存在TOTAL與PCS作為判斷標準

Sub get_value()
Dim Sh As Worksheet, a As Range, Ar(), B As Range, B1 As Range
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
fd = ThisWorkbook.Path & "\" & "PI_PO\"
fs = Dir(fd & "*xls*")
Do Until fs = ""
With Workbooks.Open(Filename:=fd & fs, UpdateLinks:=False)
n = Split(fs, " ")(0)
s = InStr(n, "BCM") + 3
fn = Mid(n, s)
For Each Sh In .Sheets
With Sh
If Trim(.Name) <> "PO" And Trim(.Name) <> "PI" Then GoTo 10
ay = .UsedRange.Value
For i = 1 To UBound(ay)
mystr = UCase(Join(Application.Index(ay, i)))
If InStr(mystr, "TOTAL") > 0 And InStr(mystr, "PCS") > 0 Then
For j = 1 To UBound(ay, 2)
If ay(i, j) = "PCS" Then d(Trim(.Name) & "數量") = ay(i, j - 1): yn = True
If IsNumeric(ay(i, j)) And yn = True Then d(Trim(.Name) & "金額") = ay(i, j): yn = False: Exit For
Next
End If
Next
20
End With
10
Next
ReDim Preserve Ar(y)
Ar(y) = Array(fn, d("PI數量"), d("PI金額"), d("PO數量"), d("PO金額"), fs)
y = y + 1
.Close
d.RemoveAll
End With
fs = Dir
Loop
Sheets("Records").[A2].Resize(y, 6) = Application.Transpose(Application.Transpose(Ar))
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

複製代碼

學海無涯_不恥下問