- ©«¤l
- 4901
- ¥DÃD
- 44
- ºëµØ
- 24
- ¿n¤À
- 4916
- ÂI¦W
- 243
- §@·~¨t²Î
- Windows 7
- ³nÅ骩¥»
- Office 20xx
- ¾\ŪÅv
- 150
- ©Ê§O
- ¨k
- ¨Ó¦Û
- ¥x¥_
- µù¥U®É¶¡
- 2010-4-30
- ³Ì«áµn¿ý
- 2024-11-9
|
¦^´_ 9# luke - Sub ZipAsWb2() 'À£ÁY¦¨Zip
- '°Ñ¦Òcrdotlin«e½úhttp://blog.xuite.net/crdotlin/excel/20830799-%E4%B8%80%E6%AC%A1%E6%80%A7%E6%9B%BF%E6%8F%9B
- Dim ZipFile, srFolder, nFile, ofile
- Dim theShell As Object
- '«ü©w¨Ó·½Àɮתº¸ê®Æ§¨
- f = ThisWorkbook.Path
- srFolder = f
- 'Àˬd¸ê®Æ§¨¬O§_¦s¦b
- Set theShell = CreateObject("Shell.Application")
- If theShell.Namespace(srFolder) Is Nothing Then
- MsgBox srFolder & " ¸ê®Æ§¨¤£¦s¦b!"
- End
- End If
- 'Àˬd¬O§_¬°ªÅªº¸ê®Æ§¨
- If theShell.Namespace(srFolder).items.Count = 0 Then
- MsgBox srFolder & " ¸ê®Æ§¨¤¤¨S¥ô¦óÀɮצs¦b!"
- End
- End If
- '¶}±Ò¤@ӪŪºZipÀ£ÁYÀÉ®×
- ZipFile = f & ".zip"
- Open ZipFile For Output As #1
- '¼g¤JZIPÀÉÀY
- Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
- Close #1
- '½Æ»s¨C¤@Ó¦bzipÀɤ¤ªºÀÉ®×
- On Error Resume Next
- For Each ofile In theShell.Namespace(srFolder).items
- If ofile <> ".zip" Then theShell.Namespace(ZipFile).CopyHere (ofile)
- '²³æ¼È°±1¬íµ¥Ô½Æ»s§¹¦¨
- Application.Wait Now + 1 / 86400#
- Next
- End Sub
- Sub InputCSV() 'Ū¤JCSV
- Dim ary() As String, rw As Long
- i = 0: k = 1
- Cells.ClearContents
- path1 = ThisWorkbook.Path & "\"
- file1 = Dir(path1 & "*.*", vbDirectory) '¥u³B²z¸ê®Æ§¨
- Do While file1 <> ""
- If file1 <> "." And file1 <> ".." And _
- GetAttr(path1 & file1) = vbDirectory Then
- i = i + 1
- ReDim Preserve ary(i)
- ary(i) = file1
- End If
- file1 = Dir
- Loop
- For i = 1 To UBound(ary)
- path2 = path1 & ary(i) & "\"
- fs = Dir(path2 & "*.csv")
- Do Until fs = ""
- If Split(fs, ".")(0) = ary(i) Then
- Open path2 & fs For Input As #1
- r = 1
- Do Until EOF(1)
- Line Input #1, mystr
- ar = Split(mystr, ",")
- Cells(r, k).Resize(, UBound(ar) + 1) = ar
- r = r + 1
- Loop
- k = k + 2
- Close #1
- End If
- fs = Dir
- Loop
- Next i
- End Sub
- Sub OutputCSV() '¿é¥XCSV
- path1 = ThisWorkbook.Path & "\"
- k = 1
- Do Until Cells(1, k) = ""
- r = 1
- fs = path1 & Cells(1, k + 1) & "\" & Cells(1, k + 1) & ".csv"
- Open fs For Output As #1
- Do Until Cells(r, k) = ""
- mystr = Cells(r, k) & "," & Cells(r, k + 1)
- Print #1, mystr
- r = r + 1
- Loop
- Close #1
- k = k + 2
- Loop
- End Sub
½Æ»s¥N½X |
|