[µo°Ý] ¦p¦ó±q¤£¦P¸ê®Æ§¨¶×¤J¤å¦rÀÉ

luke

¦U¦ì¤j¤j

¦p¦ó±q¤£¦Pªº¸ê®Æ§¨¶×¤J¤å¦rÀÉ¦Ü sheet1ªíA:JÄæ

·Ð½Ð¥ý¶i«ü¾É!

TEST10.rar (18.93 KB)

¤U¸ü¦¸¼Æ: 7

2012-4-15 12:05

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

luke

¦^´_ 7# register313


    ÁÂÁÂR¤j

    ­Y·Q±NÂà¥X«áªº¸ê®Æ§¨(³s¦P¤å¦rÀÉ), «ö¤Usheet1ªí"À£ÁY"«ö¶s¨Ó¤À§O§@¸ê®Æ§¨À£ÁY
     ¦pLAN0¸ê®Æ§¨À£ÁY¦¨LAN0.rar

     ·Ð½Ð¥ý¶i, ¤j¤j«ü¾É
       TEST10-2A.rar (33.86 KB)

¤U¸ü¦¸¼Æ: 3

2012-4-16 11:38

luke

¦^´_ 5# Hsieh


    ÁÂÁÂH¤j

    Ū¤JCSVÀɮ׮Ƨ¨¤º¦³Ãþ¦ü¦WºÙ, ¦pD:\LAN0¸ê®Æ§¨¤º¦³LAN0.csv©MLAN6.csv¨â­Ó¤å¦rÀÉ®É,
    LAN6.csv¤]·|³Q¶×¤J(¥u»Ý¶×¤JLAN0.csv)

    ¶i¦æ¿é¥XCSV®É, ¸ÓLAN6.csv§ä¤£¨ì¸ô®|·|¥X²{¿ù»~

   
     ¥H¤WÀ³¦p¦óÁקK¿ù»~
     ·Ð½Ð¥ý¶i«ü¾É
      TEST1B.rar (22.74 KB)

¤U¸ü¦¸¼Æ: 1

2012-4-15 23:39

register313

¦^´_ 6# luke

1. Sub Âà¤J()
   
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 刴X()
    
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

½Æ»s¥N½X

luke

¦^´_ 4# register313

   ÁÂÁÂR¤j

   ­Y¸ê®Æ§¨·s¼W¦h¤FD:\LAN0ªºLAN0.csv§Y
   A:B¨âÄæÀx¦s¦ÜD:\LAN0¸ê®Æ§¨ªºLAN0.csv
  C:D¨âÄæÀx¦s¦ÜD:\LAN1¸ê®Æ§¨ªºLAN1.csv
  E:F¨âÄæÀx¦s¦ÜD:\LAN2¸ê®Æ§¨ªºLAN2.csv
  G:H¨âÄæÀx¦s¦ÜD:\LAN3¸ê®Æ§¨ªºLAN3.csv
  I:J¨âÄæÀx¦s¦ÜD:\LAN4¸ê®Æ§¨ªºLAN4.csv
  K:L¨âÄæÀx¦s¦ÜD:\LAN5¸ê®Æ§¨ªºLAN5.csv

  ·Ð½Ð¥ý¶i, ¤j¤j«ü¾É¦p¦ó­×§ï?

TEST10-1A.rar (25.6 KB)

¤U¸ü¦¸¼Æ: 3

2012-4-15 22:34

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

register313

¦^´_ 3# luke

1. Sub Âà¤J()
   
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 刴X()
    
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

½Æ»s¥N½X

luke

¦^´_ 2# register313


    ÁÂÁÂR¤j

    ­Y¸ê®Æ¦³­×§ï¦p·s¼W¸ê®Æ©ósheet1ªíA:JÄ檺A11:J17
    ¥i§_§ó·sÂà¦s¦^¦Ü­ì¸ê®Æ§¨ªº¤å¦rÀÉ

   A11:B17Äæ¬O·s¼W¥[¸ê®Æ±ýÂà¦s¦ÜD:\LAN1¸ê®Æ§¨LAN1.csvªº1,2Äæ
   C11:D17Äæ¬O·s¼W¥[¸ê®Æ±ýÂà¦s¦ÜD:\LAN2¸ê®Æ§¨LAN2.csvªº1,2Äæ
   E11:F17Äæ¬O·s¼W¥[¸ê®Æ±ýÂà¦s¦ÜD:\LAN3¸ê®Æ§¨LAN3.csvªº1,2Äæ
   G11:H17Äæ¬O·s¼W¥[¸ê®Æ±ýÂà¦s¦ÜD:\LAN4¸ê®Æ§¨LAN4.csvªº1,2Äæ
   I17:J17Äæ¬O·s¼W¥[¸ê®Æ±ýÂà¦s¦ÜD:\LAN5¸ê®Æ§¨LAN5.csvªº1,2Äæ

   ·Ð½Ð¥ý¶i, ¤j¤j«ü¾É
TEST10-1.rar (26.57 KB)

¤U¸ü¦¸¼Æ: 5

2012-4-15 17:35

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

½Æ»s¥N½X