帖子: 6
主題: 1
精華: 0
積分: 7
點名: 0
作業系統: Win 10
軟體版本: Office 2016
閱讀權限: 10
性別: 男
註冊時間: 2022-4-13
最後登錄: 2022-5-25

1^# 跳轉到 » 倒序看帖

字體大小: tT

發表於 2022-4-13 14:09 | 只看該作者

[發問] VBA程式開啟一個相同檔名不同檔案

本帖最後由癡肥羔羊於 2022-4-13 14:12 編輯

抱歉想詢問各位:
如何可以先開啟一個相同檔名不同檔案，將資料處理後另存一個新檔案，之後進行輪迴。
目前已有成功開啟，但他會按照資料夾裡面的片數全數開啟

以下是我的vba程式:
Sub A開啟檔案()

Dim lrow As Long
Dim mFile As String
Dim Filename As String

mFile = Dir(ThisWorkbook.Path & "\csv檔\" & "*.csv")
Do While mFile <> ""
Workbooks.Open Filename:=ThisWorkbook.Path & "\csv檔\" & mFile
mFile = Dir()

mFile = Dir(ThisWorkbook.Path & "\TXT檔\" & "*.txt")
Do While mFile <> ""
Workbooks.Open Filename:=ThisWorkbook.Path & "\TXT檔\" & mFile
mFile = Dir()
Loop
Loop

End Sub
再麻煩幫我確認及修改...謝謝~~

1.jpg (34.97 KB)

檔案入徑

2.jpg (13.43 KB)

3.png (13.6 KB)

4.jpg (103.99 KB)

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-8-22

2^#

發表於 2022-4-13 15:31 | 只看該作者

回復 1# 癡肥羔羊

看不太懂您的需求為何?可以上傳附件和需求結果，謝謝
將資料處理後另存一個新檔案>> 資料怎麼處理?

TOP

癡肥羔羊

小學生 Rank: 1

帖子: 6
主題: 1
精華: 0
積分: 7
點名: 0
作業系統: Win 10
軟體版本: Office 2016
閱讀權限: 10
性別: 男
註冊時間: 2022-4-13
最後登錄: 2022-5-25

3^#

發表於 2022-4-14 08:36 | 只看該作者

回復 2# samwang

不好意思說明的不清楚，目前是想開兩個相同檔案但不同副檔名CSV與TXT，然後再將TXT裡面的資料複製在CSV檔，然後另存檔案在進行輪迴。
目前資料處理到另存檔案已處理好，但卡在第一關開啟檔案的部分，原因是當資料夾裡有第二個excel檔以上時會同時一起開下去

以下是所有的程式碼:
Sub A開啟SPI_TXT()

Dim lrow As Long
Dim mFile As String
Dim Filename As String

If Len(Dir(ThisWorkbook.Path & "\TEST", vbDirectory)) = 0 Then
MkDir ThisWorkbook.Path & "\TEST"
End If

mFile = Dir(ThisWorkbook.Path & "\csv檔\" & "*.csv")
Do While mFile <> ""
Workbooks.Open Filename:=ThisWorkbook.Path & "\csv檔\" & mFile
mFile = Dir()

mFile = Dir(ThisWorkbook.Path & "\TXT檔\" & "*.txt")
Do While mFile <> ""
Workbooks.Open Filename:=ThisWorkbook.Path & "\TXT檔\" & mFile
mFile = Dir()

Loop
Loop

Run "TXT複製至CSV"

End Sub

Sub TXT複製至CSV()

Workbooks(2).Activate
Workbooks(2).Worksheets.Add Before:=Sheets(Sheets.Count)
'活頁2(CSV)新增工作表

For i = 1 To Sheets.Count
Sheets(i).Name = "Sheet" & i
Next

Workbooks(3).Activate
Columns("A:A").Select
Selection.Copy
Workbooks(2).Activate
Sheets("Sheet1").Select
ActiveSheet.Paste
'將活頁3(TXT)資料複製至活頁2(CSV)

Application.CutCopyMode = False
Workbooks(3).Close

Run "另存TEST檔"

End Sub
Sub 另存TEST檔()

Filename = ActiveWorkbook.Name
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\TEST\" & Filename, _
FileFormat:=xlCSV, CreateBackup:=False
Application.DisplayAlerts = True
Application.WindowState = xlNormal
'另存TEST

ActiveWindow.Close SaveChanges:=False

End Sub

附件檔案可以試跑，再麻煩幫我看看....謝謝

Desktop.zip (20.45 KB)

試跑巨集

TOP

癡肥羔羊

小學生 Rank: 1

帖子: 6
主題: 1
精華: 0
積分: 7
點名: 0
作業系統: Win 10
軟體版本: Office 2016
閱讀權限: 10
性別: 男
註冊時間: 2022-4-13
最後登錄: 2022-5-25

4^#

發表於 2022-4-14 11:11 | 只看該作者

回復 3# 癡肥羔羊

或是說當開啟相同名稱時，使他中斷迴圈進行下一個Run的巨集，不知是否可行??

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-8-22

5^#

發表於 2022-4-15 07:55 | 只看該作者

回復 3# 癡肥羔羊

需求如附件那樣嗎? 請測試看看，謝謝

TEST.zip (32.33 KB)

TOP

癡肥羔羊

小學生 Rank: 1

帖子: 6
主題: 1
精華: 0
積分: 7
點名: 0
作業系統: Win 10
軟體版本: Office 2016
閱讀權限: 10
性別: 男
註冊時間: 2022-4-13
最後登錄: 2022-5-25

6^#

發表於 2022-4-17 17:16 | 只看該作者

回復 5# samwang

非常抱歉...我不能下載附件，權限不足:'( :'(
可copy文字給我看嗎??謝謝妳~

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-8-22

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)