[發問] 如何輸入某字串再搜查多個檔案複製到主檔案中

rcyw

請教各位:

本人想將放在同一folder(e.g. C\Temp\..) 的4個檔案中(A,B,C,D), 先輸入想搜尋的code, 再複製到 main.xls 檔的指定位置...
自己的vba程度真的太差, 希望有高人指導一下, 自覺好像很複雜...先感謝..

1. 先開啟 main 檔,  建立一個按鈕彈出 或 建立一個可輸入的位, 輸入想要搜查的code, 如輸入 "KTRIG")
2. 輸入後, 會到 C\Temp\ 中, 搜查 A,B,C,D 檔中的相同 code, 再順序 (xxxxxG11, xxxxxG1B, xxxxxG21,...) 整行複製到指定的 A File Data, B File Data, C File Data, D File Data 下,

A,B,C,D 檔案的欄位都是固定的, 但code的次序更新後都不會是順序排列. 和code都會一路增加的...

准提部林

搜尋文字放在Range("B2")
Sub 搜尋複製()
Dim FindTxt$, xA As Range, PH$, F, xRR As Range
Dim xB As Workbook, xS As Worksheet, xU As Range, N&
FindTxt = [B2]
If FindTxt = "" Then MsgBox "搜尋文字未輸入!  ": Exit Sub
Call 清除: Set xA = [A20]
PH = ThisWorkbook.Path  '路徑>>自行改為C:\Temp
Application.ScreenUpdating = False
For Each F In Array("A", "B", "C", "D")
    Set xRR = Nothing: N = 1
    If Dir(PH & "\" & F & ".csv") = "" Then GoTo 101
    Set xB = Workbooks.Open(PH & "\" & F & ".csv")
    Set xS = xB.Sheets(1): Set xU = xS.UsedRange
    Set xRR = xU.Rows(1)
    For i = 2 To xU.Rows.Count
        If InStr(xU.Cells(i, 1), FindTxt) > 0 Then
           N = N + 1: Set xRR = Union(xRR, xU.Rows(i))
        End If
    Next i
    xA = F & " File Data": xA.Resize(1, 4).Interior.ColorIndex = 4
    xRR.Copy xA(2): Set xA = xA(N + 3)
    xB.Close 0
101: Next
End Sub

搜尋及複製.rar (95.97 KB)

下載次數: 10

2019-5-5 11:11

======

rcyw

先感謝版主准提部林的協助...複製到主檔案的都是需要的資料, 但可能是自己之前沒說清楚..

因資料在檔案A,B,C,D複製到主程式後, 自己還需用vlookup取出分別在A,B,C,D相同code後的不同資料....
所以希望綠色行 20,35,50,64..的 " x File Data" 是不變, .....A,B,C,D複製出的資料都在綠色行之下, 有些code會是有空行, 就如附圖..

輸出到這個結果是否可行呢?...先感謝.

准提部林

應該是隔15列, 20-35-50-65

Sub 搜尋複製()
Dim FindTxt$, xA(4) As Range, PH$, F, xRR As Range
Dim xB As Workbook, xS As Worksheet, xU As Range, N&
FindTxt = [B2]
If FindTxt = "" Then MsgBox "搜尋文字未輸入!  ": Exit Sub
Call 清除
PH = ThisWorkbook.Path
For i = 1 To 4
    Set xA(i) = Range("A" & Array(20, 35, 50, 65)(i - 1))
Next i
Application.ScreenUpdating = False
For Each F In Array("A", "B", "C", "D")
    Set xRR = Nothing
    If Dir(PH & "\" & F & ".csv") = "" Then GoTo 101
    Set xB = Workbooks.Open(PH & "\" & F & ".csv")
    Set xS = xB.Sheets(1): Set xU = xS.UsedRange
    Set xRR = xU.Rows(1)
    For i = 2 To xU.Rows.Count
        If InStr(xU.Cells(i, 1), FindTxt) > 0 Then Set xRR = Union(xRR, xU.Rows(i))
    Next i
    N = N + 1
    xA(N) = F & " File Data": xA(N).Resize(1, 4).Interior.ColorIndex = 4
    xRR.Copy xA(N)(2)
    xB.Close 0
101: Next
End Sub

rcyw

真的很感謝和佩服版主准提部林的幫忙, 這麼快就改到了, 這正是自己所需要的....

自己的程度實在太差了, 要加倍努力一下......

再次感謝...

rcyw

另外發現有一個問題....就是由A,B,C,D搜尋出來 複製到主程式中,,..不是順序的.
例如: 當A檔被更新過後, 排列不是順序的話..複製出來的結果會不是順序..xxxxxG21, xxxxxG11, xxxxxG3B...

自己多加了下列的程式, 分別先將A,B,C,D先排列一次, 才執行版主准提部林的程式...這樣出來的結果就可以4個檔案出來的都是順序....輸出來的數據都是自己想要的....

    Workbooks.Open Filename:="C:\Temp\A.csv"
    Selection.AutoFilter
    ActiveWorkbook.Worksheets("A").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("A").AutoFilter.Sort.SortFields.Add Key:= _
        Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("A").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Save
    ActiveWorkbook.Close SaveChanges:=True

但都想學習一下, 是否有更好的更改, 不需先將想搜尋的檔案逐個排列, (e.g. xxxxxG11, xxxxxG1B, xxxxxG21...) 出來時的結果就可以"順序"輸出來呢?

先感謝...

准提部林

回復 6# rcyw


Sub 搜尋複製()
Dim FindTxt$, xA(4) As Range, PH$, F, xRR As Range
Dim xB As Workbook, xS As Worksheet, xU As Range, N&, V&
FindTxt = [B2]
If FindTxt = "" Then MsgBox "搜尋文字未輸入!  ": Exit Sub
Call 清除
PH = ThisWorkbook.Path
For i = 1 To 4
    Set xA(i) = Range("A" & Array(20, 35, 50, 65)(i - 1))
Next i
Application.ScreenUpdating = False
For Each F In Array("A", "B", "C", "D")
    Set xRR = Nothing
    If Dir(PH & "\" & F & ".csv") = "" Then GoTo 101
    Set xB = Workbooks.Open(PH & "\" & F & ".csv")
    Set xS = xB.Sheets(1): Set xU = xS.UsedRange
    Set xRR = xU.Rows(1): V = 0
    For i = 2 To xU.Rows.Count
        If InStr(xU.Cells(i, 1), FindTxt) > 0 Then V = V + 1: Set xRR = Union(xRR, xU.Rows(i))
    Next i
    N = N + 1
    xA(N) = F & " File Data": xA(N).Resize(1, 4).Interior.ColorIndex = 4
    xRR.Copy xA(N)(2)
    With xA(N)(3).Resize(V, xU.Columns.Count)
        .Sort Key1:=.Item(1), Order1:=xlAscending, Header:=xlNo
    End With   
    xB.Close 0
101: Next
End Sub


========

rcyw

再次感謝版主准提部林...原來就這樣加了三行左右就已經改變了,

真的非常感謝...