vba 資料夾內的檔案，逐一複製到新檔，再另存

#excel #vba excel vba excel vba

akissiva 2020-09-22 16:22:41 ‧ 13284 瀏覽

分享至

各位大大好
小妹為vba小白，用一點點程式基礎+錄製巨集+google，努力了4天還是搞不定
不知道問題在哪，只會跑一次就停了

想達到的：
把資料夾C:\Users\vi\Downloads\原始資料\內每個檔案的A1:E5儲存格資料，貼到篩選表(是固定的，已寫好12個工作表的陣列)，再分別以原檔案的名稱另存
C:\Users\vi\Downloads\原始資料\A02.csv　→複製A1:E5儲存格　→到篩選表s2~s13的A2貼上　→到C:\Users\vi\Downloads\轉出資料\ 存檔為A02.xls　→再重複這個過程

Sub 嘗試()
    Dim mFile As String
    For i = 1 To 200
        mFile = Dir("C:\Users\viva\Downloads\原始資料\*.csv")
    Next i
    
    Do While mFile <> ""
        Workbooks.Open Filename:="C:\Users\viva\Downloads\原始資料\" & mFile
        mFile = Dir()
        Range("A1:E5").Select
        Selection.Copy
        Windows("篩選表.xls").Activate
        Sheets(Array("s2", "s3", "s4", "s5", "s6", "s7", "s8", "s9", "s10", "s11", "s12", _
        "s13")).Select
        Sheets("s2").Activate
        Range("A2").Select
        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
        nName = Application.Workbooks(2).Name
        Workbooks("篩選表.xls").SaveAs "C:\Users\viva\Downloads\轉出資料\" & nName & ".xls"
        Workbooks.Close
        Workbooks(2).Close
    Loop
End Sub

skyksl066 iT邦新手 4 級 ‧ 2020-09-22 16:31:24 檢舉

因為目前手邊沒windows電腦沒辦法幫你測試不過，你上面的程式有問題。
```
For i = 1 To 200
mFile = Dir("C:\Users\viva\Downloads\原始資料\*.csv")
Next i
```
這段沒意義跑了200次都一直在覆蓋掉mFile這個變數
```
Do While mFile <> "" 當mFile不等於空白

但是下面mFile = Dir()又把它變空白了
```
改一下因該就會跑了

akissiva iT邦新手 5 級 ‧ 2020-09-22 17:11:10 檢舉

大大您好
我把For迴圈拿掉，Dir的()拿掉，就完全不會跑了......
謝謝

登入發表討論

直播研討會

{{ item.channelVendor }} {{ item.webinarstarted }} |

直播中

2 個回答

skyksl066

iT邦新手 4 級 ‧ 2020-09-22 20:20:38

最佳解答

Sub aaa()
    Dim mFile As String
    mFile = Dir("C:\Users\vi\Downloads\原始資料\*.csv")
    Workbooks.Open Filename:="C:\Users\vi\Downloads\對照.xlsx"
    Do While mFile <> ""
        Debug.Print mFile
            Workbooks.Open Filename:="C:\Users\vi\Downloads\原始資料\" & mFile
            Range("A1:E5").Select
            Selection.Copy
            Workbooks(2).Activate
            Sheets(Array("s2", "s3", "s4", "s5", "s6", "s7", "s8", "s9", "s10", "s11", "s12")).Select
            Sheets("s2").Activate
            Range("A2").Select
            Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
            xlNone, SkipBlanks:=False, Transpose:=False
            nName = Application.Workbooks(3).Name
            Workbooks(2).SaveAs "C:\Users\vi\Downloads\轉出資料\" & nName & ".xlsx"
            Workbooks(3).Close

        mFile = Dir
    Loop
    Workbooks(2).Close
End Sub

將“對照.xlsx”檔案那隻關閉這個設定並存檔

滑鼠移到 Excel 視窗上方的功能列，
依序點選【工具(T)】、【選項(O)】、及【安全性】，
在『隱私選項』下面有一個核取方塊寫著『存檔時自檔案摘要資訊中移除個人資訊(R)』，
試著不要打勾，然後點選【確定】。

-2007路徑
檔案/選項/信任中心/信任中心設定/隱私選項/
取消勾選存檔時自檔案摘要資訊中移除私人資訊

實測可用
思考流路
1.檔案1為vba主程式
檔案2為對照.xlsx
檔案3為x.csv
2.主程式執行
3.取得csv路徑
4.開啟對照.xlsx
5.開啟x.csv
6.do something
7.取得csv名稱
8.另存對照為x.csv.xlsx
9.關閉x.csv
10.回5
11.完成後關閉對照.xlsx

回應 2
分享
檢舉

akissiva iT邦新手 5 級 ‧ 2020-09-23 11:00:16 檢舉

sk大
成功了~成功了~~
感動得亂七八糟
當下是摀著嘴、手抖、眼眶泛淚、驚喜交加
真的不敢相信，天阿
好開心阿~~~~~~~~~~~~~

來快樂地說說測試的細節
『存檔時自檔案摘要資訊中移除個人資訊(R)』原本就是沒打勾的
我想了想sk大所講的邏輯，把vba放一個空的xls當主程式，把要套用的格式放在對照.xls，跑起來速度更快了
好像沒講什麼，原諒小妹我現在整個興奮到升天

真的原本以為是for迴圈擺放位置的問題，沒想到壓根問題不在那

感恩大大，讚頌大大，

繼續來參悟一下思考卡住的地方
太開心了

akissiva iT邦新手 5 級 ‧ 2020-09-25 17:03:20 檢舉

這幾天我把新舊兩隻程式對照著看，試著理清思路，也嘗試改寫
問題就像sk大大說過的：「VBA沒辦法幫自己另存檔再繼續執行」
即使是不關掉它也沒辦法繼續當Workbooks(1)
不知道這是不是VBA本身的限制

想起幾天前就是硬要寫在一張表、鑽進死胡同，感到有點羞
感想：寫程式，能達到目的，總比寫不出來好，思路要靈活

但對比週一寫到生無可戀的自己，此刻就像重新活過來一樣
再次謝謝兩位大大的指導

登入發表回應

海綿寶寶

iT邦大神 1 級 ‧ 2020-09-22 16:44:21

試試看
會不會顯示出所有 csv 檔名
會的話
再把你原來那些 code
填進去

Sub Macro1()
    Dim mFile As String
    
    mFile = Dir("C:\Users\viva\Downloads\原始資料\*.csv")

    Do While mFile <> ""
        Debug.Print mFile
        '=======================
        '要做的事寫在這裡
        '=======================
        mFile = Dir
    Loop
End Sub

回應 15
分享
檢舉

看更多先前的回應...收起先前的回應...

akissiva iT邦新手 5 級 ‧ 2020-09-22 17:05:11 檢舉

大大您好
試了一下，沒有顯示任何東西(還是說它應該顯示在哪邊??)，看起來xls沒有在動
填入code後，還是只有跑一次

謝謝

海綿寶寶 iT邦大神 1 級 ‧ 2020-09-22 17:15:06 檢舉

應該顯示在下圖下方的位置
(我用 *.jpg 測試，出現 *.jpg 檔名)
如果沒有顯示
就是路徑/檔名不對，或是程式寫錯

akissiva iT邦新手 5 級 ‧ 2020-09-22 17:39:31 檢舉

大大您好
有的，即時運算視窗叫出來，執行巨集有顯示出所有csv檔名，

把code貼上去後，只有轉了一個檔案出來

謝謝

海綿寶寶 iT邦大神 1 級 ‧ 2020-09-22 17:44:39 檢舉

執行巨集有顯示出所有csv檔名

我提供的程式只解決這個問題

剩下的部份
建議你自己按 F8 (逐行執行) 鍵一步一步執行
看看是那一段有問題

skyksl066 iT邦新手 4 級 ‧ 2020-09-22 17:51:49 檢舉

海綿大大的程式沒問題喔，我看了一下是你執行的思考流路有問題

Workbooks("篩選表.xls").SaveAs "C:\Users\viva\Downloads\轉出資料\" & nName & ".xls"
' 另外這邊另存的新檔名稱會是nName.xls.xls
Workbooks.Close
Workbooks(2).Close

這邊有問題
首先你執行ＶＢＡ的表單是？？？
如果是篩選表，VBA沒辦法幫自己令另存檔
然後把第一張表跟第二張關掉
這邊有產生一個問題如果你的表單只有2張都關光了誰做事？
所以他只跑一次

建議先把while拿掉，一條一條跑過一次沒問題再加上while

akissiva iT邦新手 5 級 ‧ 2020-09-22 18:07:42 檢舉

海綿大大謝謝
正在努力中

akissiva iT邦新手 5 級 ‧ 2020-09-22 18:16:57 檢舉

sk大大
剛剛逐行跑後，我也發現了這個很ㄎㄧㄤ狀況

因此把原本程式碼內有"篩選表.xls"的，都改成Workbooks(1)
然後最後面只關閉Workbooks(2).Close，Workbooks(1)只存檔而不關

好的，我試試把while先拿掉，一加進for就整個怪怪的

謝謝

akissiva iT邦新手 5 級 ‧ 2020-09-22 18:22:21 檢舉

把while先拿掉後，整個程式是沒有問題的
跑第二次，檔案仍是開第一個，不會開第二個
阿阿...迴圈，弄了4天還是卡在這

skyksl066 iT邦新手 4 級 ‧ 2020-09-22 18:23:44 檢舉

能幫上忙就好了，哈哈哈
最後還有一個問題saveAs完之後狀態列上的篩選表.xls變成x.xls了第二輪也沒有篩選表.xls可以選中了

skyksl066 iT邦新手 4 級 ‧ 2020-09-22 18:23:49 檢舉

能幫上忙就好了，哈哈哈
最後還有一個問題saveAs完之後狀態列上的篩選表.xls變成x.xls了第二輪也沒有篩選表.xls可以選中了

佔了一格隨便打點什麼好了。

1.excel VBA腳本
2.然後去開啟篩選表
3.開啟csv
4.do something
5.另存篩選表
6.關閉另存的篩選表
7.關閉csv
8.回2

建議流路設計（只是建議）

skyksl066 iT邦新手 4 級 ‧ 2020-09-22 18:24:29 檢舉

手機怪怪的發了二次XD

akissiva iT邦新手 5 級 ‧ 2020-09-22 18:33:38 檢舉

sk大
我是以不關閉的Workbooks(1).Activate用來當底，只需反覆貼上不同資料另存，

真的不知道問題出在哪....到底為什麼不能持續往下開資料夾內檔案運作.....

skyksl066 iT邦新手 4 級 ‧ 2020-09-22 18:52:35 檢舉

你可以把，最新版的程式碼貼上來看看

akissiva iT邦新手 5 級 ‧ 2020-09-22 19:43:17 檢舉

sk大
目前程式長這樣

Sub Macro1()
    Dim mFile As String
    mFile = Dir("C:\Users\vi\Downloads\原始資料\*.csv")
    Do While mFile <> ""
        Debug.Print mFile

            Workbooks.Open Filename:="C:\Users\vi\Downloads\原始資料\" & mFile
            mFile = Dir()
            Range("A1:E5").Select
            Selection.Copy
            Workbooks(1).Activate
            Sheets(Array("s2", "s3", "s4", "s5", "s6", "s7", "s8", "s9", "s10", "s11", "s12", _
             "s12")).Select
            Sheets("s2").Activate
            Range("A2").Select
            Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
            xlNone, SkipBlanks:=False, Transpose:=False
            nName = Application.Workbooks(2).Name
            Workbooks(1).SaveAs "C:\Users\vi\Downloads\轉出資料\" & nName & ".xls"
            Workbooks(2).Close

        mFile = Dir
    Loop
End Sub