[發問] 如何在不打開檔案下，將XML檔或CSV檔匯入EXCEL中

paul3063

如何在不打開檔案下，將XML檔或CSV檔匯入EXCEL中
網址如下
https://data.gov.tw/dataset/9122
下載XML檔，JSON檔跟CSV檔
卻發現XML檔和JSON檔打不開
CSV檔可以
可是資料龐大，
超過65536列
出現文字檔案多於能容納的資料
使用文字匯入精靈來排除已經匯入的資料
請問有什麼辦法將資料快速平均匯入到SHEET1跟SHEET2跟SHEET3

jackyq

方法1: csv 格式很簡單, 自己寫個解析器,  很容易就可以匯入 ( 不然 google 應該可以找得到現成的 )
方法2:
用 Open CSV_FileName For Input As #1 把 csv大檔 切割成小於 65536 列的 數個小 csv 檔
再把這些小 csv 逐一匯入到 sheet1, sheet2 ....

paul3063

回復 2# jackyq


請問可以用CreateObject("ADODB.CONNECTION")的方法嗎

jackyq

回復 3# paul3063


Private Function Get_CSVFile_Object(ByVal File_FullPathName As String) As Object
      Set rs = CreateObject("ADODB.Recordset")
    Set conn = CreateObject("ADODB.Connection")
   
    strFileName = CreateObject("Scripting.FileSystemObject").GetFileName(File_FullPathName)
    strFilePath = CreateObject("Scripting.FileSystemObject").GetParentFolderName(File_FullPathName)
    aa = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
         "Data Source=" & strFilePath & ";" & _
         "Extended Properties='text;HDR=Yes;FMT=Delimited(,);CharacterSet=65001'"
    conn.Open aa, "", ""

    rs.Open "select * from [" & strFileName & "]", conn, adOpenStatic, adLockReadOnly, adCmdText
    Set Get_CSVFile_Object = rs
End Function

Private Sub GO______()
   
    Dim rsData As Object

    Csv = "C:\我的資料檔.csv"   ' 自己改成檔案真實路徑

    Set rsData = Get_CSVFile_Object(Csv)
   
    If rsData.RecordCount > 0 Then

        ReDim col(0 To rsData.Fields.Count)
        For w = 0 To rsData.Fields.Count - 1
            col(w) = rsData.Fields(w).Name
        Next   
        MsgBox Join(col, vbCrLf)
   
        rsData.MoveFirst
        Do While Not rsData.EOF
            For w = 0 To rsData.Fields.Count - 1
                col(w) = rsData.Fields(w).Value
                If IsNull(col(w)) Then col(w) = ""
            Next
            MsgBox Join(col, vbCrLf)
            Stop
            rsData.MoveNext
        Loop
    End If
    rsData.Close
End Sub

jackyq

回復 3# paul3063

把資料分派到 sheet1 , sheet2 ..

勞煩大大自己處裡

paul3063

回復 5# jackyq


    請問程式碼要放在那裡?
THISWORKBOOK裡面
還是MODULE裡面?

jackyq

回復 6# paul3063

放 module 好了
不過要把 private 字樣 改成 public
不然會呼叫不到

GBKEE

回復 6# paul3063
放那裡都可以,2003跑程式約需2分鐘,其他版本約8-10秒
試試看

1. Option Explicit
   
2. Sub Ex_CVS的分割()
   
3.     Dim i As Long, S As Variant, Ar As Variant, X As Long, xData As Long, Sh As Integer, xTime As Date
   
4.     Dim Msg As String
   
5.     xTime = Time
   
6.     On Error GoTo XER
   
7.     With CreateObject("Microsoft.XMLHTTP")
   
8.         .Open "POST", "D:\EXCEL\36_2.csv", 0
   
9.         .send
   
10.         S = Split(.responseText, vbCrLf)
    
11.     End With
    
12.     xData = 10000 '**每一工作表分割資料數 10000
    
13.     Ar = Replace(S(0), """,""", ",")
    
14.     Ar = Replace(Ar, """", "")
    
15.     Ar = Split(Ar, ",")
    
16.    
    
17.     For i = 1 To Application.Ceiling(UBound(S) / xData, 1)
    
18.         Sheets(i).Cells.Clear
    
19.         Sheets(i).Cells(1, "a").Resize(, UBound(Ar) + 1) = Ar
    
20.     Next
    
21.     Sh = 1
    
22.     X = 2
    
23.     For i = 1 To UBound(S)
    
24.         If i >= xData And i Mod xData = 0 Then Sh = Sh + 1: X = 2
    
25.         Ar = Replace(S(i), """,""", ",")
    
26.         Ar = Replace(Ar, """", "")
    
27.         Ar = Split(Ar, ",")
    
28.         Sheets(Sh).Cells(X, "a").Resize(, UBound(Ar) + 1) = Ar
    
29.         X = X + 1
    
30.     Next
    
31.     MsgBox Application.Text(Time - xTime, ["m分:S秒"]) & " ok"
    
32.     If Msg <> "" Then
    
33.         MsgBox Msg
    
34.         ThisWorkbook.Sheets.Add , Sheets(Sheets.Count)
    
35.         Ar = Application.Transpose(Split(Msg, vbLf))
    
36.         ActiveSheet.Range("a1").Resize(UBound(Ar) + 1) = Ar
    
37.     End If
    
38. Exit Sub
    
39. XER:
    
40.   
    
41.     Dim ii
    
42.      '處理程式中 Sheets(i).Cells.Clear ˇ的錯誤
    
43.     If Err = 9 Then ThisWorkbook.Sheets.Add , Sheets(Sheets.Count): Resume
    
44.      '處理程式中 .Resize(, UBound(Ar) + 1) = Ar ˇ的錯誤
    
45.    '2003 **陣列的元素字元數大於255 個字元,會有錯誤
    
46.    '2003 以後的版本沒有此錯誤
    
47.     For ii = 0 To UBound(Ar)
    
48.         Sheets(Sh).Cells(X, ii + 1) = Ar(ii)
    
49.         If Len(Ar(ii)) > 456 Then
    
50.             Msg = Msg & Sheets(Sh).Cells(X, ii + 1).Address(, , , 1, 1) & " 字元數" & Len(Ar(ii)) & vbLf
    
51.         End If
    
52.     Next
    
53.     Resume Next
    
54. 
    
55. End Sub

複製代碼

paul3063

回復 8# GBKEE

GBKEE大，
我用匯入的方法好像比較快
可是匯入的方法只有起始列
沒有終止列真的很奇怪

Sub Macro4()
    Range("A1").Select
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\Documents and Settings\Administrator\My Documents\Downloads\36_2.csv\36_2.csv" _
        , Destination:=Range("A1"))
        .Name = "36_4"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = -535
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
        1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Range("D6").Select
    Sheets("Sheet1").Select
    ActiveWorkbook.Worksheets.Add
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\Documents and Settings\Administrator\My Documents\Downloads\36_2.csv\36_2.csv" _
        , Destination:=Range("A1"))
        .Name = "36_4"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = -535
        .TextFileStartRow = 30001
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
        1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
End Sub

GBKEE

回復 9# paul3063

QueryTable 是沒有終止列這屬性
你的程式碼在2003運行還是受到65536列的限制
如圖

下載 (314.63 KB)

2018-1-17 11:12

修改程式看看 2003,2010 的差異

1. Option Explicit
   
2. Sub Macro4()
   
3.    Dim i As Integer
   
4.     For i = 1 To IIf(Rows.Count > 65536, 1, 2)
   
5.         With Sheets(i).QueryTables.Add(Connection:="TEXT;d:\excel\36_2.csv" _
   
6.             , Destination:=Sheets(i).Range("A" & i))
   
7.             .Name = "36_4"
   
8.             .FieldNames = True
   
9.             .RowNumbers = True
   
10.             .RefreshStyle = xlInsertDeleteCells
    
11.             .SaveData = True
    
12.             .AdjustColumnWidth = False  '自動將欄寬調整為最適合的大小
    
13.             .TextFilePlatform = -535
    
14.             .TextFileStartRow = IIf(i = 1, 1, 32767)
    
15.             .TextFileCommaDelimiter = True '***
    
16.             .Refresh BackgroundQuery:=False
    
17.     End With
    
18.     If i = 2 Then Sheets(2).Rows(1) = Sheets(1).Rows(1).Value
    
19.     Next
    
20. End Sub

複製代碼