麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] vba開啟並抓取指定資料夾內關鍵字檔案&活頁名稱資料 [打印本頁]

作者: msmplay 時間: 2018-2-6 22:45 標題: vba開啟並抓取指定資料夾內關鍵字檔案&活頁名稱資料

[attach]28334[/attach][attach]28335[/attach]
說明:
按下【按鈕1】時，自動開啟指定資料夾內檔案『list20180206135132.xls』，並將活頁名稱「list20180206135132」A:Z資料貼至此活頁A1，再將檔案『list20180206135132.xls』關閉

遇到問題:
檔案『list20180206135132.xls』除了 list 為固定字串，後面的日期時間數字均不固定，包含檔案內的活頁名稱也是一樣只有 list 為固定字串，後面的日期時間數字均不固定
因此巨集在寫的時候希望可以改為開啟指定關鍵字檔名『list』的檔案，例如list201802081532、list201803290915…以此類推，只要檔名有『list』關鍵字即符合條件，活頁名稱也是一樣

提醒:
指定資料夾內不只一個檔案，所以不能不指定檔名，否則有可能開到別的檔案了，以上求解~~~~~~~~~~

[attach]28336[/attach]

作者: GBKEE 時間: 2018-2-7 10:05

回復 1# msmplay

自動開啟指定資料夾內檔案『list*.xls』第一個工作表的 A:Z資料複製到活頁[list報表]A欄，再將檔案『list*.xls』關閉

Option Explicit
Sub Ex()
Dim xDir As String, xPath As String, xWb As Workbook
xPath = ThisWorkbook.Path
xDir = Dir(xPath & "\list*.xls", vbDirectory)
Do While xDir <> ""
Set xWb = Workbooks.Open(xPath & "\" & xDir)
With ThisWorkbook.Sheets("list報表").Range("A1").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
xDir = Dir
Loop
End Sub

複製代碼

作者: msmplay 時間: 2018-2-7 21:16

回復 2# GBKEE

G大非常感謝幫忙~~~~~測試已成功喔!!!再次感謝ㄟ

作者: msmplay 時間: 2018-2-9 19:57

回復 2# GBKEE

G大~~~~~不好意思，小妹好像遇到了一個超蠢的問題耶!!!就是如果同時有4個檔案要匯入，而且檔名都不一樣的時候該怎麼修改呢???例如：檔1『list*.xls』要匯入活頁「list報表」的A1
檔2『CCMOP*.xls』要匯入活頁「有資料」的B1
檔3『CCMOP_NAME*.xls』要匯入活頁「無資料」的B1
檔4『預約表單*.xls』要匯入活頁「預約表單」的A1

因為我發現我自己怎麼改好像都不行那~~~~~

作者: GBKEE 時間: 2018-2-11 08:33

本帖最後由 GBKEE 於 2018-2-15 07:55 編輯

回復 4# msmplay

'檔1『list*.xls』要匯入活頁「list報表」的A1
'檔2『CCMOP*.xls』要匯入活頁「有資料」的B1
'檔3『CCMOP_NAME*.xls』要匯入活頁「無資料」的B1
'檔4『預約表單*.xls』要匯入活頁「預約表單」的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

複製代碼

作者: msmplay 時間: 2018-2-11 09:31

回復 5# GBKEE

G大好厲害ㄛ你！真是超級感謝你的熱血幫忙ㄛ

作者: jeffrey628litw 時間: 2018-2-12 19:27

回復 msmplay
GBKEE 發表於 2018-2-11 08:33

大師有小筆誤：第11列 Aeray 是Array 哦

作者: GBKEE 時間: 2018-2-15 07:57

回復 7# jeffrey628litw
粗心大意,感謝指出,

作者: msmplay 時間: 2018-2-22 19:58

回復 8# GBKEE

哈~~~~~G大，對不起~~~~小妹又來煩你了，因為不管自己怎麼亂改就是不會成功，可以再請你幫我個忙嗎~~~~~~就是上次4#的問題，如果想再多加以下條件，到底該怎麼修改才對呢？？因為發現不同的報表有不同需求.........

一樣是4個檔案要匯入，但條件如下:
檔1『list*.xls』的Sheets(1)要匯入活頁「list報表」的A1
檔2『CCMOP*.xls』的Sheets(1)跟Sheets(2)要匯入活頁「有資料」的B1跟活頁「有資料2」的B1
檔3『CCMOP_NAME*.xls』的Sheets(1)跟Sheets(2)要匯入活頁「無資料」的B1跟活頁「無資料2」的B1
檔4『預約表單*.xls』的Sheets(4)要匯入活頁「預約表單」的A1

作者: msmplay 時間: 2018-3-1 22:58

回復 8# GBKEE

G大~~~~我自己大概試改了一下，可以請你幫我看看醬對不對嗎？但我已經盡力了............

然後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

作者: Hsieh 時間: 2018-3-5 16:11

本帖最後由 Hsieh 於 2018-3-6 17:20 編輯

回復 10# msmplay
試試看

Sub ex()
Dim xlPath$
xlPath = ThisWorkbook.Path
Set fd = CreateObject("Scripting.Dictionary")
fa = Array("list", "CCMOP_NAME", "CCMOP", "預約表單")
sh = Array("list報表", "無資料", "無資料2", "有資料", "有資料2", "預約表單")
an = Array(1, 1, 2, 1, 2, 4)
For i = 0 To UBound(fa)
f = Dir(xlPath & "\" & fa(i) & "*.xls")
Do Until f = ""
If fd.exists(f) = False Then
fd(f) = f
With Workbooks.Open(xlPath & "\" & f)
If i = 0 Then
ar = Array(1)
ElseIf i = 1 Or i = 2 Then
ar = Array(1, 2)
Else
ar = Array(4)
End If
For j = 0 To UBound(ar)
With .Sheets(ar(j))
If k = 0 Or k = 5 Then Rng = "A1" Else Rng = "B1"
.Range("A1").CurrentRegion.Copy ThisWorkbook.Sheets(sh(k)).Range(Rng)
End With
k = k + 1
Next
.Close 0
End With
End If
f = Dir
Loop
Next
End Sub

複製代碼

作者: msmplay 時間: 2018-3-5 19:18

回復 11# Hsieh

H大~~~~首先非常非常非常感謝你熱心幫忙喔~~~~~~~不過測試結果為：
檔1『list*.xls』的Sheets(1)要匯入活頁「list報表」的A1：成功匯入
檔2『CCMOPQ*.xls』的Sheets(1)跟Sheets(2)要匯入活頁「有資料」的B1跟活頁「有資料2」的B1：Sheets(1)成功匯入「有資料」的B1，Sheets(2)未匯入但匯入成Sheets(1)到「有資料2」的B1
檔3『CCMOP_NAME*.xls』的Sheets(1)跟Sheets(2)要匯入活頁「無資料」的B1跟活頁「無資料2」的B1：Sheets(1)成功匯入「無資料」的B1，Sheets(2)未匯入但匯入成Sheets(1)到「無資料2」的B1
檔4『預約表單*.xls』的Sheets(4)要匯入活頁「預約表單」的A1：未匯入

可以再請你幫忙看看嗎~~~~~~

作者: msmplay 時間: 2018-3-6 18:57

回復 11# Hsieh

H大~~~~測試成功了喔!!!非常感謝~~~~~~~

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