Board logo

標題: [發問] 如何從不同資料夾匯入文字檔 [打印本頁]
作者: luke    時間: 2012-4-15 12:05     標題: 如何從不同資料夾匯入文字檔

各位大大

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

煩請先進指導!

[attach]10445[/attach]
作者: register313    時間: 2012-4-15 14:21

回復 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    時間: 2012-4-15 17:33

本帖最後由 luke 於 2012-4-15 17:36 編輯

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

   煩請先進, 大大指導
[attach]10447[/attach]
作者: register313    時間: 2012-4-15 18:09

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

  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    時間: 2012-4-15 22:32

回復 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    時間: 2012-4-15 22:35

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

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

[attach]10451[/attach]
作者: register313    時間: 2012-4-15 22:55

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

  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    時間: 2012-4-15 23:39

回復 5# Hsieh


    謝謝H大

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

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

   
     以上應如何避免錯誤
     煩請先進指導
     [attach]10453[/attach]
作者: luke    時間: 2012-4-16 11:38

回復 7# register313


    謝謝R大

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

     煩請先進, 大大指導
      [attach]10455[/attach]
作者: Hsieh    時間: 2012-4-16 20:25

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

  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
複製代碼




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