- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
本帖最後由 GBKEE 於 2018-1-18 17:05 編輯
回復 6# paul3063
放那裡都可以,2003跑程式約需2分鐘,其他版本約8-10秒
試試看- Option Explicit
- Sub Ex_CVS的分割()
- Dim i As Long, S As Variant, Ar As Variant, X As Long, xData As Long, Sh As Integer, xTime As Date
- Dim Msg As String
- xTime = Time
- On Error GoTo XER
- With CreateObject("Microsoft.XMLHTTP")
- .Open "POST", "D:\EXCEL\36_2.csv", 0
- .send
- S = Split(.responseText, vbCrLf)
- End With
- xData = 10000 '**每一工作表分割資料數 10000
- Ar = Replace(S(0), """,""", ",")
- Ar = Replace(Ar, """", "")
- Ar = Split(Ar, ",")
-
- For i = 1 To Application.Ceiling(UBound(S) / xData, 1)
- Sheets(i).Cells.Clear
- Sheets(i).Cells(1, "a").Resize(, UBound(Ar) + 1) = Ar
- Next
- Sh = 1
- X = 2
- For i = 1 To UBound(S)
- If i >= xData And i Mod xData = 0 Then Sh = Sh + 1: X = 2
- Ar = Replace(S(i), """,""", ",")
- Ar = Replace(Ar, """", "")
- Ar = Split(Ar, ",")
- Sheets(Sh).Cells(X, "a").Resize(, UBound(Ar) + 1) = Ar
- X = X + 1
- Next
- MsgBox Application.Text(Time - xTime, ["m分:S秒"]) & " ok"
- If Msg <> "" Then
- MsgBox Msg
- ThisWorkbook.Sheets.Add , Sheets(Sheets.Count)
- Ar = Application.Transpose(Split(Msg, vbLf))
- ActiveSheet.Range("a1").Resize(UBound(Ar) + 1) = Ar
- End If
- Exit Sub
- XER:
-
- Dim ii
- '處理程式中 Sheets(i).Cells.Clear ˇ的錯誤
- If Err = 9 Then ThisWorkbook.Sheets.Add , Sheets(Sheets.Count): Resume
- '處理程式中 .Resize(, UBound(Ar) + 1) = Ar ˇ的錯誤
- '2003 **陣列的元素字元數大於255 個字元,會有錯誤
- '2003 以後的版本沒有此錯誤
- For ii = 0 To UBound(Ar)
- Sheets(Sh).Cells(X, ii + 1) = Ar(ii)
- If Len(Ar(ii)) > 456 Then
- Msg = Msg & Sheets(Sh).Cells(X, ii + 1).Address(, , , 1, 1) & " 字元數" & Len(Ar(ii)) & vbLf
- End If
- Next
- Resume Next
- End Sub
|
|
發表於 2018-1-12 08:44
| 
