- 帖子
- 4901
- 主題
- 44
- 精華
- 24
- 積分
- 4916
- 點名
- 267
- 作業系統
- Windows 7
- 軟體版本
- Office 20xx
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台北
- 註冊時間
- 2010-4-30
- 最後登錄
- 2025-10-31
               
|
9#
發表於 2012-6-5 23:24
| 只看該作者
回復 7# luke - Sub Split_CSV()
- Dim Ar(), Ay()
- Set d = CreateObject("Scripting.Dictionary")
- Application.DisplayAlerts = False
- Application.ScreenUpdating = False
- fd = ThisWorkbook.Path & "\"
- fs = fd & "TEST21.csv"
- Set wb = Workbooks.Open(fs)
- yn = False
- With wb.Sheets(1) '分割檔案
- k = .UsedRange.Columns.Count
- For Each a In .Range(.[A1], .Cells(.Rows.Count, 1).End(xlUp))
- If yn = False And InStr(a, ".csv") > 0 Then _
- yn = True: r = 1: _
- f = Replace(Replace(Replace(a, "[", ""), "]", ""), "*", ""): _
- Set sh = wb.Sheets.Add(after:=wb.Sheets(1))
- Ar = a.Resize(, k).Value
- With sh
- If yn = True Then
- .Cells(r, 1).Resize(, k) = Ar: r = r + 1
- ReDim Preserve Ay(s)
- Ay(s) = Join(Application.Transpose(Application.Transpose(Ar)), Chr(9))
- s = s + 1
- End If
- End With
- If InStr(a, "div") > 0 Then fs = fd & "結果\" & f: yn = False: sh.Move: ActiveWorkbook.SaveAs fd & "結果\" & f, 6: Workbooks(f).Close: d(f) = Join(Ay, Chr(10)): Erase Ay: s = 0
- Next
- End With
- wb.Close 0
- fs = Dir(fd & "*.csv")
- Do Until fs = ""
- If fs <> "TEST21.csv" Then
- Set wb = Workbooks.Open(fd & fs)
- With wb.Sheets(1)
- k = .UsedRange.Columns.Count
- ReDim Ar(k)
- Ar(0) = "[*" & fs & "*]"
- For i = 1 To k - 1
- Ar(i) = ""
- Next
- ReDim Preserve Ay(s)
- Ay(s) = Join(Ar, Chr(9))
- s = s + 1
- For Each a In .UsedRange.Columns(1).Cells
- Ar = a.Resize(, k).Value
- ReDim Preserve Ay(s)
- Ay(s) = Join(Application.Transpose(Application.Transpose(Ar)), Chr(9))
- s = s + 1
- Next
- ReDim Preserve Ay(s)
- Ay(s) = Join(Array("", "", "", "", "", "", "", ""), Chr(9))
- s = s + 1
- ReDim Ar(k)
- Ar(0) = "[*div*]"
- For i = 1 To k - 1
- Ar(i) = ""
- Next
- ReDim Preserve Ay(s)
- Ay(s) = Join(Ar, Chr(9))
- s = s + 1
- d(fs) = Join(Ay, Chr(10))
- Erase Ay: s = 0
- End With
- wb.Close 0
- End If
- fs = Dir
- Loop
- With Worksheets.Add
- .[A1].Resize(d.Count, 1) = Application.Transpose(d.keys)
- .[A1].Resize(d.Count, 1).Sort key1:=.[A1], Header:=xlNo
- Ar = .[A1].Resize(d.Count, 1).Value
- r = 1
- For Each ky In Ar '組合檔案
- an = Split(d(ky), Chr(10))
- For j = 0 To UBound(an)
- ak = Split(an(j), Chr(9))
- .Cells(r, 1).Resize(, UBound(ak) + 1) = ak
- r = r + 1
- Next
- r = r + 1
- Next
- .Move
- ActiveWorkbook.SaveAs fd & "結果\" & "TEST21OK.csv", 6
- ActiveWorkbook.Close 1
- End With
- Application.DisplayAlerts = True
- Application.ScreenUpdating = True
- End Sub
|
|
發表於 2012-6-2 16:44
| 
