EXCEL+TXT檔案文字擷取?

新增彙總跟NEW 2個工作表(只匯入到A欄)
放到txt同資料夾內

Sub SV()
Application.ScreenUpdating = False
Sheets("NEW").Cells.Clear
Sheets("彙總").Cells.Clear
Sheets("NEW").Select

DirPath = ThisWorkbook.Path
fs = Dir(DirPath & "\*.txt")
Do Until fs = ""
r = r + 1
yy = [A1048576].End(xlUp).Row + 1
If yy = 2 Then
yy = 1
Else
yy = yy
End If
''======載入txt
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" + DirPath & "\" & fs, Destination:=Range("$A$" & yy))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 950
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With

Set yy = Nothing
fs = Dir
Loop


k = 1
For i = 1 To [A1048576].End(xlUp).Row
Cx = Cells(i, 1)
If Cx Like "*" & "ABC" Then
Rows(i - 1 & ":" & i).Copy Sheets("彙總").Cells(k, 1)
k = k + 2
End If
Next
Application.ScreenUpdating = True
End Sub