返回列表 上一主題 發帖

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

[發問] 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)

檔案入徑

1.jpg

2.jpg (13.43 KB)

2.jpg

3.png (13.6 KB)

3.png

4.jpg (103.99 KB)

4.jpg

回復 1# 癡肥羔羊


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

TOP

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

回復 3# 癡肥羔羊

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

TOP

回復 3# 癡肥羔羊


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

TEST.zip (32.33 KB)

TOP

回復 5# samwang


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

TOP

本帖最後由 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)

1.JPG

完成後結果.JPG (52.41 KB)

完成後結果.JPG

TOP

回復 7# samwang

會跳出此問題~檔案已有按照圖片1都放在file裡面。

1.png (27.77 KB)

1.png

2.png (23.97 KB)

next issue

2.png

TOP

回復 8# 癡肥羔羊

可以提供你的資料檔案(有出現問題),我來測試看看,謝謝

TOP

回復 9# samwang


因原始檔案是蠻長的,再幫我確認看看,謝謝

圖片1.jpg (23.23 KB)

圖片1.jpg

圖片2.jpg (44.67 KB)

圖片2.jpg

219U30400100306.zip (32.22 KB)

CSV

219U30400100306_TXT.zip (32.27 KB)

TXT

TOP

        靜思自在 : 一個人不怕錯,就怕不改過,改過並不難。
返回列表 上一主題