帖子: 17
主題: 6
精華: 0
積分: 73
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 20
註冊時間: 2018-11-2
最後登錄: 2024-10-18

1^# 跳轉到 » 倒序看帖

字體大小: tT

發表於 2019-5-4 19:08 | 只看該作者

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

本帖最後由 rcyw 於 2019-5-4 19:12 編輯

請教各位:

本人想將放在同一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都會一路增加的...

Main.zip (104.04 KB)

樓主熱帖

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2833
主題: 10
精華: 0
積分: 2889
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-17

2^#

發表於 2019-5-5 11:12 | 只看該作者

搜尋文字放在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)

======

TOP

rcyw

中學生 Rank: 2

帖子: 17
主題: 6
精華: 0
積分: 73
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 20
註冊時間: 2018-11-2
最後登錄: 2024-10-18

3^#

發表於 2019-5-5 14:43 | 只看該作者

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

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

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

copy.jpg (68 KB)

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2833
主題: 10
精華: 0
積分: 2889
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-17

4^#

發表於 2019-5-5 15:07 | 只看該作者

應該是隔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

TOP

rcyw

中學生 Rank: 2

帖子: 17
主題: 6
精華: 0
積分: 73
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 20
註冊時間: 2018-11-2
最後登錄: 2024-10-18

5^#

發表於 2019-5-5 15:15 | 只看該作者

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

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

再次感謝...

TOP

rcyw

中學生 Rank: 2

帖子: 17
主題: 6
精華: 0
積分: 73
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 20
註冊時間: 2018-11-2
最後登錄: 2024-10-18

6^#

發表於 2019-5-6 21:21 | 只看該作者

本帖最後由 rcyw 於 2019-5-6 21:22 編輯

另外發現有一個問題....就是由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...) 出來時的結果就可以"順序"輸出來呢?

先感謝...

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2833
主題: 10
精華: 0
積分: 2889
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-17

7^#

發表於 2019-5-7 10:51 | 只看該作者

本帖最後由准提部林於 2019-5-8 10:03 編輯

回復 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

========

TOP

rcyw

中學生 Rank: 2

帖子: 17
主題: 6
精華: 0
積分: 73
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 20
註冊時間: 2018-11-2
最後登錄: 2024-10-18

8^#

發表於 2019-5-7 20:29 | 只看該作者

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

真的非常感謝...

TOP