­ã´£³¡ªL

·j´M¤å¦r©ñ¦bRange("B2")
Sub ·j´M½Æ»s()
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 "·j´M¤å¦r¥¼¿é¤J!  ": Exit Sub
Call ²M°£: 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

·j´M¤Î½Æ»s.rar (95.97 KB)

¤U¸ü¦¸¼Æ: 10

2019-5-5 11:11

======

­ã´£³¡ªL

À³¸Ó¬O¹j15¦C, 20-35-50-65

Sub ·j´M½Æ»s()
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 "·j´M¤å¦r¥¼¿é¤J!  ": Exit Sub
Call ²M°£
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

­ã´£³¡ªL

¦^´_ 6# rcyw


Sub ·j´M½Æ»s()
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 "·j´M¤å¦r¥¼¿é¤J!  ": Exit Sub
Call ²M°£
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


========