- 帖子
- 976
- 主題
- 7
- 精華
- 0
- 積分
- 1018
- 點名
- 0
- 作業系統
- Win10
- 軟體版本
- Office 2016
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2013-4-19
- 最後登錄
- 2025-1-10
|
7#
發表於 2022-4-17 18:20
| 只看該作者
本帖最後由 samwang 於 2022-4-17 18:22 編輯
回復 6# 癡肥羔羊
所有檔案放在file的資料夾如附圖,請測試看看,謝謝
Sub 載入文字檔()
Dim PH$, FN$, Arr(1 To 2000, 1 To 3), n&, fs, f, fc, T, j%
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Set fs = CreateObject("Scripting.FileSystemObject")
If Len(Dir(ThisWorkbook.Path & "\TEST", vbDirectory)) = 0 Then
MkDir ThisWorkbook.Path & "\TEST"
End If
PH = ThisWorkbook.Path & "\file\"
Do
If FN = "" Then FN = Dir(PH & "*.txt") Else FN = Dir
If FN = "" Then Exit Do
Open PH & "\" & FN For Input As #1
While Not EOF(1)
Line Input #1, T
n = n + 1
If InStr(T, ",") < 1 Then
Arr(n, 1) = T
Else
TR = Split(T, ",")
For j = 0 To 2: Arr(n, j + 1) = TR(j): Next
End If
Wend
Close #1
FN1 = Split(FN, ".")(0)
Set f = fs.GetFolder(PH): Set fc = f.Files
For Each f1 In fc
If UCase(Split(f1.Name, ".")(1)) = "CSV" Then
If Split(f1.Name, ".")(0) = FN1 Then
With Workbooks.Open(f1.Path)
With Sheets(1)
R = .Range("a65536").End(3).Row + 1
.Range("a" & R).Resize(n, 3) = Arr
'另存TEST檔
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\TEST\" & FN1, _
FileFormat:=xlCSV, CreateBackup:=False
ActiveWindow.Close SaveChanges:=False
End With
End With
End If
End If
Next
Erase Arr: n = 0
Loop
Set f = Nothing: Set fs = Nothing: Set fc = Nothing
Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub |
-
-
1.JPG
(17.71 KB)
-
-
完成後結果.JPG
(52.41 KB)
|