Board logo

標題: [發問] VBA程式 開啟一個相同檔名不同檔案 [打印本頁]
作者: 癡肥羔羊    時間: 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
再麻煩幫我確認及修改...謝謝~~
作者: samwang    時間: 2022-4-13 15:31

回復 1# 癡肥羔羊


看不太懂您的需求為何?可以上傳附件和需求結果，謝謝
將資料處理後另存一個新檔案>> 資料怎麼處理?
作者: 癡肥羔羊    時間: 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

附件檔案可以試跑，再麻煩幫我看看....謝謝
作者: 癡肥羔羊    時間: 2022-4-14 11:11

回復 3# 癡肥羔羊

或是說當開啟相同名稱時，使他中斷迴圈進行下一個Run的巨集，不知是否可行??
作者: samwang    時間: 2022-4-15 07:55

回復 3# 癡肥羔羊


需求如附件那樣嗎? 請測試看看，謝謝
作者: 癡肥羔羊    時間: 2022-4-17 17:16

回復 5# samwang


非常抱歉...我不能下載附件，權限不足:'( :'(
可copy文字給我看嗎??謝謝妳~
作者: samwang    時間: 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
作者: 癡肥羔羊    時間: 2022-4-18 08:56

回復 7# samwang

會跳出此問題~檔案已有按照圖片1都放在file裡面。
作者: samwang    時間: 2022-4-18 11:24

回復 8# 癡肥羔羊

可以提供你的資料檔案(有出現問題)，我來測試看看，謝謝
作者: 癡肥羔羊    時間: 2022-4-20 08:45

回復 9# samwang


因原始檔案是蠻長的，再幫我確認看看，謝謝
作者: samwang    時間: 2022-4-20 10:06

回復 10# 癡肥羔羊

更改如下紅字，請再測試看看，謝謝
Dim PH$, FN$, Arr(1 To 65536, 1 To 3)
作者: lee88    時間: 2022-4-21 14:14

TXT資料複製到Csv的程式碼對嗎!
  1. Option Explicit
  2. Dim WB As Workbook, Csv_File As String, Txt_File As String, Txt_Path As String, Csv_Path As String, Save_Path As String
  3. Sub Ex_Main()
  4.     Dim Msg As Variant
  5.     檢查資料夾
  6.     Application.ScreenUpdating = False
  7.     Application.StatusBar = "            程式執行中...................."
  8.     Csv_File = Dir(Csv_Path & "\*.csv")
  9.     Msg = Csv_File
  10.     Do While Csv_File <> ""
  11.         Txt_File = Txt_Path & "\" & Split(Csv_File, ".")(0) & ".txt"                    '修改csv 副檔名 為txt
  12.         If CreateObject("Scripting.FileSystemObject").FileExists(Txt_File) = False Then MsgBox "找不到 " & vbLf & Txt_File & vbLf & "檢查後 重新執行程式!": End
  13.         Set WB = Workbooks.Open(Csv_Path & Csv_File)
  14.         TXT複製至CSV
  15.         Csv_File = Dir()
  16.         Msg = Msg & vbLf & Csv_File
  17.     Loop
  18.     Application.StatusBar = False
  19.     Application.ScreenUpdating = True
  20.     Msg = Split(Msg, vbLf)
  21.     MsgBox Join(Msg, vbLf) & "完成TXT複製至CSV  " & UBound(Msg) & " 個檔案"
  22. End Sub
  23. Private Sub 檢查資料夾()
  24.     Dim Msg As String
  25.     Save_Path = ThisWorkbook.Path & "\Test\"                     'TXT複製至CSV  存檔的資料夾
  26.     Csv_Path = ThisWorkbook.Path & "\csv檔\"                     'csv檔檔的資料夾
  27.     Txt_Path = ThisWorkbook.Path & "\TXT檔\"                     'TXT檔的資料夾
  28.     If Dir(Save_Path, vbDirectory) = "" Then
  29.          If MsgBox("建立 " & Save_Path & "  資料夾", vbYesNo) = vbYes Then
  30.             MkDir (Save_Path)
  31.          End If
  32.     End If
  33.     If Dir(Csv_Path, vbDirectory) = "" Then Msg = "找不到 " & Csv_Path
  34.     If Dir(Txt_Path, vbDirectory) = "" Then Msg = Msg & vbLf & "找不到 " & Txt_Path
  35.     If Msg <> "" Then MsgBox Msg & vbLf & "檢查後 重新執行程式!": End
  36. End Sub
  37. Private Sub TXT複製至CSV()
  38.     Dim Sh As Worksheet, Rng As Range
  39.     Set Sh = Workbooks.Open(Txt_File).Sheets(1)                              '開啟TXT的Sheets(1)
  40.     Set Rng = WB.Sheets(1).Range("a1").End(xlDown).Offset(1)   'TXT資料複製到Csv的指定位置
  41.     If Rng.Row = Rows.Count Then Set Rng = WB.Sheets(1).Range("a1")
  42.     '指定位置的Row= Rows.Count  **指定位置在檔案底部時 --A欄中沒有資料
  43.     With Sh.Range("A1")                     '資料剖析A欄  -,,,-> Comma:=True
  44.         .CurrentRegion.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
  45.             TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
  46.             Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
  47.             :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
  48.         .CurrentRegion.Copy Rng    '**TXT資料複製到Csv
  49.     End With
  50.     Sh.Parent.Close False                                  'Sh(Worksheet).Parent(父層-Workbook)關閉
  51.     If CreateObject("Scripting.FileSystemObject").FileExists(Save_Path & Csv_File) Then Kill Save_Path & Csv_File
  52.         '**CreateObject("Scripting.FileSystemObject").FileExists=True **表檔案存在,故執行  Kill
  53.     With WB
  54.         .SaveAs Save_Path & Csv_File               '-Workbook另存\Test\ 的 Csv檔
  55.         '****   FileExists=True **  .SaveAs 會提示是否取代原檔案--   程式暫時中斷執行
  56.         .Close True
  57.     End With
  58. End Sub
複製代碼
回復 3# 癡肥羔羊
作者: lee88    時間: 2022-4-21 15:19

  1. Sub Ex_Main()
  2.     Dim Msg As Variant
  3.     檢查資料夾
  4.     Application.ScreenUpdating = False
  5.     Application.StatusBar = "            程式執行中...................."
  6.     Csv_File = Dir(Csv_Path & "\*.csv")
  7.     Msg = Csv_File
  8.     Do While Csv_File <> ""
  9.         Txt_File = Txt_Path & "\" & Split(Csv_File, ".")(0) & ".txt"                    '修改csv 副檔名 為txt
  10.         If CreateObject("Scripting.FileSystemObject").FileExists(Txt_File) = False Then MsgBox "找不到 " & vbLf & Txt_File & vbLf & "檢查後 重新執行程式!": End
  11.         Set WB = Workbooks.Open(Csv_Path & Csv_File)
  12.         TXT複製至CSV
  13.         Csv_File = Dir()
  14.         Msg = Msg & vbLf & Csv_File
  15.     Loop
  16.     Application.StatusBar = False
  17.     Application.ScreenUpdating = True
  18.    '**********加上這If 判斷程式碼 ,程式會完整些*****************
  19. If Msg <> "" Then
  20.         Msg = Split(Msg, vbLf)
  21.         MsgBox Join(Msg, vbLf) & "完成TXT複製至CSV  " & UBound(Msg) & " 個檔案"
  22.     Else
  23.         MsgBox "沒有任何TXT檔複製至CSV檔"
  24.     End If
  25. '************************************************
  26. End Sub
複製代碼
回復 12# lee88



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)