台灣最大程式設計社群網站
線上人數
1111
 
會員總數:242482
討論主題:187519
歡迎您免費加入會員
討論區列表 >> office VBA / WinOS >> 抓取關鍵字檔名不同活頁資料
[]  
[我要回覆]
1
回應主題 加入我的關注話題 檢舉此篇討論 將提問者加入個人黑名單
抓取關鍵字檔名不同活頁資料
價值 : 50 QP  點閱數:233 回應數:9

樓主

小麥
門外漢
0 3
42 6
發送站內信

之前有向網大們求解出以下巨集,主要是抓取5個關鍵字檔案("list*.xls", "CCMOP*.xls", "CCMOP_NAME*.xls", "預約表單*.xls")
並將檔案內第1個活頁資料自動帶入「測試檔」的4個活頁"list報表", "有資料", "無資料", "預約表單",並貼上至不同欄位"A1", "B1", "B1", "A1"
-----------------------------------------------------------------------------------------------------------------
Option Explicit
Sub Ex()
Dim xDir As String, xPath As String, xWb As Workbook
Dim Sh(), Dir_Ar(), xRng(), i As Integer
Dir_Ar = Array("list*.xls", "CCMOP*.xls", "CCMOP_NAME*.xls", "預約表單*.xls")
Sh = Array("list報表", "有資料", "無資料", "預約表單")
xRng = Arry("A1", "B1", "B1", "A1")
xPath = ThisWorkbook.Path
For i = 0 To UBound(Sh)
xDir = Dir(xPath & "\" & Dir_Ar(i), vbDirectory)
Do While xDir <> ""
If i = 1 And InStr(UCase(xDir), "CCMOP_NAME") Then GoTo xNext
Set xWb = Workbooks.Open(xPath & "\" & xDir)
With ThisWorkbook.Sheets(Sh(i)).Range(xRng(i)).End(xlDown)
If .Row = .Parent.Rows.Count Then
xWb.Sheets(1).UsedRange.Copy .Cells.End(xlUp)
Else
xWb.Sheets(1).UsedRange.Copy .Cells.Offset(1)
End If
End With
xWb.Close
xNext:
xDir = Dir
Loop
Next
End Sub
-----------------------------------------------------------------------------------------------------------------
但目前遇到新問題,一樣是4個檔案要匯入,但條件如下:
檔1『list*.xls』的Sheets(1)要匯入活頁「list報表」的A1
檔2『CCMOP*.xls』的Sheets(1)跟Sheets(2)要匯入活頁「有資料1」的B1跟活頁「有資料2」的B1
檔3『CCMOP_NAME*.xls』的Sheets(1)跟Sheets(2)要匯入活頁「無資料1」的B1跟活頁「無資料2」的B1
檔4『預約表單*.xls』的Sheets(4)要匯入活頁「預約表單」的A1

因為之前都是不同檔案的第1個活頁(活頁名稱不影響),但現在是要抓不同檔案的不同活頁資料
可以請問該如何修改以上巨集有大大們知道嗎??

測試檔

搜尋相關Tags的文章: [ 檔名 ] , [ 活頁 ] ,
本篇文章發表於2018-02-28 14:41
別忘捐VP感謝幫助你的人 新手會員瞧一瞧
1樓
回應

P陳
檢舉此回應
程式中 sheets(1) 的地方可以直接給名字

xWb.Sheets(1).UsedRange.Copy .Cells.Offset(1)

xWb.Sheets("預約表單").UsedRange.Copy .Cells.Offset(1)

本篇文章回覆於2018-02-28 22:27
== 簽名檔 ==
--未登入的會員無法查看對方簽名檔--
2樓
作者回應

小麥
檢舉此回應
P大~~~~不過因為總共有4個檔案,而且每個檔案需指定的活頁都不太一樣,請問該怎麼各別指定呢?
尤其像檔2『CCMOP*.xls』、檔3『CCMOP_NAME*.xls』,一次各需抓取2個活頁資料,這...........我有點想破頭了
本篇文章回覆於2018-02-28 23:00
== 簽名檔 ==
--未登入的會員無法查看對方簽名檔--
3樓
回應

P陳
檢舉此回應
實在是看不太懂您的題目。只能猜猜看。

您的問題:那就開二個 xwb 各開二個Sheets ,就可以作很多事了。

Set xWbA = Workbooks.Open(xPath & "\" & 檔名1)
Set xWbB = Workbooks.Open(xPath & "\" & 檔名2)

sheetA1=xwbA.sheets("活頁1")
sheetA2=xwbA.sheets("活頁2")

sheetB1=xwbB.sheets("活頁1")
sheetB2=xwbB.sheets("活頁2")
本篇文章回覆於2018-03-01 07:48
== 簽名檔 ==
--未登入的會員無法查看對方簽名檔--
4樓
作者回應

小麥
檢舉此回應
P大~~~~我自己大概試改了一下,可以請你幫我看看醬對不對嗎?但我已經盡力了............然後CCMOPQ*.xls我最後多加了一下Q,因為"CCMOPQ*.xls", "CCMOP_NAME*.xls"這兩個檔名前面不會完全一樣,抱歉

Option Explicit
Sub Ex()
Dim xDir1 As String, xDir2 As String, xDir3 As String, xPath As String, xWb1 As Workbook, xWb2 As Workbook, xWb3 As Workbook
Dim Sh1(), Sh2(), Dir_Ar1(), Dir_Ar2(), xRng1(), xRng2(), i As Integer
Dir_Ar1 = Array("list*.xls", "CCMOPQ*.xls", "CCMOP_NAME*.xls")
Dir_Ar2 = Array("CCMOPQ*.xls", "CCMOP_NAME*.xls")
Sh1 = Array("list報表", "有資料1", "無資料1")
Sh2 = Array("有資料2", "無資料2")
xRng1 = Array("A1", "B1", "B1")
xRng2 = Array("B1", "B1")
xPath = ThisWorkbook.Path
For i = 0 To UBound(Sh1)
xDir1 = Dir(xPath & "\" & Dir_Ar1(i), vbDirectory)
Do While xDir1 <> ""
If i = UCase(xDir1) Then GoTo xNext1
Set xWb1 = Workbooks.Open(xPath & "\" & xDir1)
With ThisWorkbook.Sheets(Sh1(i)).Range(xRng1(i)).End(xlDown)
If .Row = .Parent.Rows.Count Then
xWb1.Sheets(1).UsedRange.Copy .Cells.End(xlUp)
Else
xWb1.Sheets(1).UsedRange.Copy .Cells.Offset(1)
End If
End With
xWb1.Close
xNext1:
xDir1 = Dir
Loop
Next
For i = 0 To UBound(Sh2)
xDir2 = Dir(xPath & "\" & Dir_Ar2(i), vbDirectory)
Do While xDir2 <> ""
If i = UCase(xDir2) Then GoTo xNext2
Set xWb2 = Workbooks.Open(xPath & "\" & xDir2)
With ThisWorkbook.Sheets(Sh2(i)).Range(xRng2(i)).End(xlDown)
If .Row = .Parent.Rows.Count Then
xWb2.Sheets(2).UsedRange.Copy .Cells.End(xlUp)
Else
xWb2.Sheets(2).UsedRange.Copy .Cells.Offset(1)
End If
End With
xWb2.Close
xNext2:
xDir2 = Dir
Loop
Next
xDir3 = Dir(xPath & "\預約表單*.xls", vbDirectory)
Do While xDir3 <> ""
Set xWb3 = Workbooks.Open(xPath & "\" & xDir3)
With ThisWorkbook.Sheets("預約表單").Range("A1").End(xlDown)
If .Row = .Parent.Rows.Count Then
xWb3.Sheets("預約表單系統資料").UsedRange.Copy .Cells.End(xlUp)
Else
xWb3.Sheets("預約表單系統資料").UsedRange.Copy .Cells.Offset(1)
End If
End With
xWb3.Close
xDir3 = Dir
Loop
End Sub
本篇文章回覆於2018-03-01 23:04
== 簽名檔 ==
--未登入的會員無法查看對方簽名檔--
5樓
回應

P陳
檢舉此回應
那您現在是那句出問題?
1.我還是看不懂您的題目
2.我沒有你的資料 看別人的程式是很痛苦的 (被判為不安全 不給下載了)
本篇文章回覆於2018-03-02 00:27
== 簽名檔 ==
--未登入的會員無法查看對方簽名檔--
6樓
回應

P陳
檢舉此回應
目前您的問題
1.開不了 XLS
2.開不了 活頁
3.沒辦法 COPY

4.請提示一下問題點,否則別人的程式是很難進入的.
本篇文章回覆於2018-03-02 09:47
== 簽名檔 ==
--未登入的會員無法查看對方簽名檔--
7樓
作者回應

小麥
檢舉此回應
P大~~~非常感謝
已重新上傳檔案http://www.funp.net/406128
目前測試可達成抓取資料需求,想再確認程式碼是否有再精簡的可能
本篇文章回覆於2018-03-02 10:07
== 簽名檔 ==
--未登入的會員無法查看對方簽名檔--
8樓
回應

P陳
檢舉此回應
1.應該沒有什麼好改的
2.建議測試資不要全部用 test,不然對還是錯都不知道。
本篇文章回覆於2018-03-02 19:46
== 簽名檔 ==
--未登入的會員無法查看對方簽名檔--
9樓
回應

P陳
檢舉此回應
如果沒有後續問題,請將本討論串關掉
本篇文章回覆於2018-03-03 07:22
== 簽名檔 ==
--未登入的會員無法查看對方簽名檔--
   
1

回覆
如要回應,請先登入.