[發問] 如何從不同資料夾匯入文字檔

luke

各位大大

如何從不同的資料夾匯入文字檔至 sheet1表A:J欄

煩請先進指導!

TEST10.rar (18.93 KB)

下載次數: 7

2012-4-15 12:05

register313

回復 1# luke

1. Sub xx()
   
2. Application.ScreenUpdating = False
   
3. Set FT = ActiveWorkbook
   
4. For X = 1 To 5
   
5.   FS = "D:\LAN" & X & "\LAN" & X & ".CSV"
   
6.   With Workbooks.Open(FS).Sheets("LAN" & X)
   
7.     FT.Sheets("Sheet1").Columns("A:B").Offset(0, (X - 1) * 2) = .Columns("A:B").Value
   
8.     .Parent.Close False
   
9.   End With
   
10. Next
    
11. Application.ScreenUpdating = True
    
12. End Sub

複製代碼

luke

回復 2# register313


    謝謝R大

    若資料有修改如新增資料於sheet1表A:J欄的A11:J17
    可否更新轉存回至原資料夾的文字檔

   A11:B17欄是新增加資料欲轉存至D:\LAN1資料夾LAN1.csv的1,2欄
   C11:D17欄是新增加資料欲轉存至D:\LAN2資料夾LAN2.csv的1,2欄
   E11:F17欄是新增加資料欲轉存至D:\LAN3資料夾LAN3.csv的1,2欄
   G11:H17欄是新增加資料欲轉存至D:\LAN4資料夾LAN4.csv的1,2欄
   I17:J17欄是新增加資料欲轉存至D:\LAN5資料夾LAN5.csv的1,2欄

   煩請先進, 大大指導
TEST10-1.rar (26.57 KB)

下載次數: 5

2012-4-15 17:35

register313

回復 3# luke

1. Sub 轉入()
   
2. Application.ScreenUpdating = False
   
3. Set FT = ActiveWorkbook
   
4. For X = 1 To 5
   
5.   FS = "D:\LAN" & X & "\LAN" & X & ".CSV"
   
6.   With Workbooks.Open(FS).Sheets("LAN" & X)
   
7.     FT.Sheets("Sheet1").Columns("A:B").Offset(0, (X - 1) * 2) = .Columns("A:B").Value
   
8.     .Parent.Close False
   
9.   End With
   
10. Next
    
11. Application.ScreenUpdating = True
    
12. End Sub
    
13. 
    
14. Sub 轉出()
    
15. Application.ScreenUpdating = False
    
16. Set FT = ActiveWorkbook
    
17. For X = 1 To 5
    
18.   FS = "D:\LAN" & X & "\LAN" & X & ".CSV"
    
19.   With Workbooks.Open(FS).Sheets("LAN" & X)
    
20.     FT.Sheets("Sheet1").Columns("A:B").Offset(0, (X - 1) * 2).Copy .Columns("A:B")
    
21.     .Parent.Close savechanges:=True
    
22.   End With
    
23. Next
    
24. Application.ScreenUpdating = True
    
25. End Sub

複製代碼

Hsieh

回復 3# luke

1. Sub InputCSV() '讀入CSV
   
2. Dim ary() As String, rw As Long
   
3. i = 0: k = 1
   
4. path1 = ThisWorkbook.Path & "\"
   
5. file1 = Dir(path1 & "*.*", vbDirectory) '只處理資料夾
   
6. Do While file1 <> ""
   
7.   If file1 <> "." And file1 <> ".." And _
   
8.      GetAttr(path1 & file1) = vbDirectory Then
   
9.      i = i + 1
   
10.      ReDim Preserve ary(i)
    
11.      ary(i) = file1
    
12.   End If
    
13.   file1 = Dir
    
14. Loop
    
15. For i = 1 To UBound(ary)
    
16. path2 = path1 & ary(i) & "\"
    
17. fs = Dir(path2 & "*.csv")
    
18. Do Until fs = ""
    
19. Open path2 & fs For Input As #1
    
20. r = 1
    
21. Do Until EOF(1)
    
22. Line Input #1, mystr
    
23. ar = Split(mystr, ",")
    
24. Cells(r, k).Resize(, UBound(ar) + 1) = ar
    
25. r = r + 1
    
26. Loop
    
27. k = k + 2
    
28. Close #1
    
29. fs = Dir
    
30. Loop
    
31. Next i
    
32. End Sub
    
33. Sub OutputCSV() '輸出CSV
    
34. path1 = ThisWorkbook.Path & "\"
    
35. k = 1
    
36. Do Until Cells(1, k) = ""
    
37.    r = 1
    
38.    fs = path1 & Cells(1, k + 1) & "\" & Cells(1, k + 1) & ".csv"
    
39.    Open fs For Output As #1
    
40.    Do Until Cells(r, k) = ""
    
41.       mystr = Cells(r, k) & "," & Cells(r, k + 1)
    
42.       Print #1, mystr
    
43.       r = r + 1
    
44.    Loop
    
45.    Close #1
    
46.    k = k + 2
    
47. Loop
    
48. End Sub

複製代碼

luke

回復 4# register313

   謝謝R大

   若資料夾新增多了D:\LAN0的LAN0.csv即
   A:B兩欄儲存至D:\LAN0資料夾的LAN0.csv
  C:D兩欄儲存至D:\LAN1資料夾的LAN1.csv
  E:F兩欄儲存至D:\LAN2資料夾的LAN2.csv
  G:H兩欄儲存至D:\LAN3資料夾的LAN3.csv
  I:J兩欄儲存至D:\LAN4資料夾的LAN4.csv
  K:L兩欄儲存至D:\LAN5資料夾的LAN5.csv

  煩請先進, 大大指導如何修改?

TEST10-1A.rar (25.6 KB)

下載次數: 3

2012-4-15 22:34

register313

回復 6# luke

1. Sub 轉入()
   
2. Application.ScreenUpdating = False
   
3. Set FT = ActiveWorkbook
   
4. For X = 0 To 5
   
5.   fs = "D:\LAN" & X & "\LAN" & X & ".CSV"
   
6.   With Workbooks.Open(fs).Sheets("LAN" & X)
   
7.     FT.Sheets("Sheet1").Columns("A:B").Offset(0, X * 2) = .Columns("A:B").Value
   
8.     .Parent.Close False
   
9.   End With
   
10. Next
    
11. Application.ScreenUpdating = True
    
12. End Sub
    
13. 
    
14. Sub 轉出()
    
15. Application.ScreenUpdating = False
    
16. Set FT = ActiveWorkbook
    
17. For X = 0 To 5
    
18.   fs = "D:\LAN" & X & "\LAN" & X & ".CSV"
    
19.   With Workbooks.Open(fs).Sheets("LAN" & X)
    
20.     FT.Sheets("Sheet1").Columns("A:B").Offset(0, X * 2).Copy .Columns("A:B")
    
21.     .Parent.Close savechanges:=True
    
22.   End With
    
23. Next
    
24. Application.ScreenUpdating = True
    
25. End Sub

複製代碼

luke

回復 5# Hsieh


    謝謝H大

    讀入CSV檔案料夾內有類似名稱, 如D:\LAN0資料夾內有LAN0.csv和LAN6.csv兩個文字檔時,
    LAN6.csv也會被匯入(只需匯入LAN0.csv)

    進行輸出CSV時, 該LAN6.csv找不到路徑會出現錯誤

   
     以上應如何避免錯誤
     煩請先進指導
      TEST1B.rar (22.74 KB)

下載次數: 1

2012-4-15 23:39

luke

回復 7# register313


    謝謝R大

    若想將轉出後的資料夾(連同文字檔), 按下sheet1表"壓縮"按鈕來分別作資料夾壓縮
     如LAN0資料夾壓縮成LAN0.rar

     煩請先進, 大大指導
       TEST10-2A.rar (33.86 KB)

下載次數: 3

2012-4-16 11:38

Hsieh

回復 9# luke

1. Sub ZipAsWb2() '壓縮成Zip
   
2. '參考crdotlin前輩http://blog.xuite.net/crdotlin/excel/20830799-%E4%B8%80%E6%AC%A1%E6%80%A7%E6%9B%BF%E6%8F%9B
   
3. Dim ZipFile, srFolder, nFile, ofile
   
4. Dim theShell As Object
   
5.     '指定來源檔案的資料夾
   
6.     f = ThisWorkbook.Path
   
7.     srFolder = f
   
8.     '檢查資料夾是否存在
   
9.     Set theShell = CreateObject("Shell.Application")
   
10.     If theShell.Namespace(srFolder) Is Nothing Then
    
11.         MsgBox srFolder & " 資料夾不存在!"
    
12.         End
    
13.     End If
    
14.     '檢查是否為空的資料夾
    
15.     If theShell.Namespace(srFolder).items.Count = 0 Then
    
16.         MsgBox srFolder & " 資料夾中沒任何檔案存在!"
    
17.         End
    
18.     End If
    
19.     '開啟一個空的Zip壓縮檔案
    
20.     ZipFile = f & ".zip"
    
21.     Open ZipFile For Output As #1
    
22.     '寫入ZIP檔頭
    
23.     Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    
24.     Close #1
    
25.     '複製每一個在zip檔中的檔案
    
26.     On Error Resume Next
    
27.     For Each ofile In theShell.Namespace(srFolder).items
    
28.         If ofile <> ".zip" Then theShell.Namespace(ZipFile).CopyHere (ofile)
    
29.         '簡單暫停1秒等候複製完成
    
30.         Application.Wait Now + 1 / 86400#
    
31.     Next
    
32. End Sub
    
33. 
    
34. Sub InputCSV() '讀入CSV
    
35. Dim ary() As String, rw As Long
    
36. i = 0: k = 1
    
37. Cells.ClearContents
    
38. path1 = ThisWorkbook.Path & "\"
    
39. file1 = Dir(path1 & "*.*", vbDirectory) '只處理資料夾
    
40. Do While file1 <> ""
    
41.   If file1 <> "." And file1 <> ".." And _
    
42.      GetAttr(path1 & file1) = vbDirectory Then
    
43.      i = i + 1
    
44.      ReDim Preserve ary(i)
    
45.      ary(i) = file1
    
46.   End If
    
47.   file1 = Dir
    
48. Loop
    
49. For i = 1 To UBound(ary)
    
50. path2 = path1 & ary(i) & "\"
    
51. fs = Dir(path2 & "*.csv")
    
52. Do Until fs = ""
    
53. If Split(fs, ".")(0) = ary(i) Then
    
54. Open path2 & fs For Input As #1
    
55. r = 1
    
56. Do Until EOF(1)
    
57. Line Input #1, mystr
    
58. ar = Split(mystr, ",")
    
59. Cells(r, k).Resize(, UBound(ar) + 1) = ar
    
60. r = r + 1
    
61. Loop
    
62. k = k + 2
    
63. Close #1
    
64. End If
    
65. fs = Dir
    
66. Loop
    
67. Next i
    
68. End Sub
    
69. Sub OutputCSV() '輸出CSV
    
70. path1 = ThisWorkbook.Path & "\"
    
71. k = 1
    
72. Do Until Cells(1, k) = ""
    
73.    r = 1
    
74.    fs = path1 & Cells(1, k + 1) & "\" & Cells(1, k + 1) & ".csv"
    
75.    Open fs For Output As #1
    
76.    Do Until Cells(r, k) = ""
    
77.       mystr = Cells(r, k) & "," & Cells(r, k + 1)
    
78.       Print #1, mystr
    
79.       r = r + 1
    
80.    Loop
    
81.    Close #1
    
82.    k = k + 2
    
83. Loop
    
84. End Sub

複製代碼