Hsieh

¦^´_ 3# luke

1. Sub InputCSV() 'Ū¤JCSV
   
2. Dim ary() As String, rw As Long
   
3. i = 0: k = 1
   
4. path1 = ThisWorkbook.Path & "\"
   
5. file1 = Dir(path1 & "*.*", vbDirectory) '¥u³B²z¸ê®Æ§¨
   
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() '¿é¥XCSV
    
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

½Æ»s¥N½X

Hsieh

¦^´_ 9# luke

1. Sub ZipAsWb2() 'À£ÁY¦¨Zip
   
2. '°Ñ¦Òcrdotlin«e½ú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.     '«ü©w¨Ó·½Àɮתº¸ê®Æ§¨
   
6.     f = ThisWorkbook.Path
   
7.     srFolder = f
   
8.     'Àˬd¸ê®Æ§¨¬O§_¦s¦b
   
9.     Set theShell = CreateObject("Shell.Application")
   
10.     If theShell.Namespace(srFolder) Is Nothing Then
    
11.         MsgBox srFolder & " ¸ê®Æ§¨¤£¦s¦b!"
    
12.         End
    
13.     End If
    
14.     'Àˬd¬O§_¬°ªÅªº¸ê®Æ§¨
    
15.     If theShell.Namespace(srFolder).items.Count = 0 Then
    
16.         MsgBox srFolder & " ¸ê®Æ§¨¤¤¨S¥ô¦óÀɮצs¦b!"
    
17.         End
    
18.     End If
    
19.     '¶}±Ò¤@­ÓªÅªºZipÀ£ÁYÀÉ®×
    
20.     ZipFile = f & ".zip"
    
21.     Open ZipFile For Output As #1
    
22.     '¼g¤JZIPÀÉÀY
    
23.     Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    
24.     Close #1
    
25.     '½Æ»s¨C¤@­Ó¦bzipÀɤ¤ªºÀÉ®×
    
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¬íµ¥­Ô½Æ»s§¹¦¨
    
30.         Application.Wait Now + 1 / 86400#
    
31.     Next
    
32. End Sub
    
33. 
    
34. Sub InputCSV() 'Ū¤JCSV
    
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) '¥u³B²z¸ê®Æ§¨
    
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() '¿é¥XCSV
    
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

½Æ»s¥N½X