Board logo

標題: [發問] 如何在不打開檔案下,將XML檔或CSV檔匯入EXCEL中 [打印本頁]

作者: paul3063    時間: 2018-1-8 02:05     標題: 如何在不打開檔案下,將XML檔或CSV檔匯入EXCEL中

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

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

回復 2# jackyq


請問可以用CreateObject("ADODB.CONNECTION")的方法嗎
作者: jackyq    時間: 2018-1-9 09:26

本帖最後由 jackyq 於 2018-1-9 09:32 編輯

回復 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    時間: 2018-1-9 09:27

回復 3# paul3063

把資料分派到 sheet1 , sheet2 ..

勞煩大大自己處裡
作者: paul3063    時間: 2018-1-9 23:02

回復 5# jackyq


    請問程式碼要放在那裡?
THISWORKBOOK裡面
還是MODULE裡面?
作者: jackyq    時間: 2018-1-11 17:38

回復 6# paul3063

放 module 好了
不過要把 private 字樣 改成 public
不然會呼叫不到
作者: GBKEE    時間: 2018-1-12 08:44

本帖最後由 GBKEE 於 2018-1-18 17:05 編輯

回復 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. End Sub
複製代碼

作者: paul3063    時間: 5 天前 23:08

回復 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    時間: 4 天前 11:12

本帖最後由 GBKEE 於 2018-1-17 11:21 編輯

回復 9# paul3063

QueryTable 是沒有終止列這屬性
你的程式碼在2003運行還是受到65536列的限制
如圖
[attach]28251[/attach]
修改程式看看 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
複製代碼

作者: paul3063    時間: 4 天前 17:06

回復 10# GBKEE

GBKEE大,如果目前工作表裡面沒有SHEET1和SHEET2,怎辦?
因為我在做測試的時候砍光了SHEET,只剩下SHEET13
要怎樣修改程式碼?
作者: c_c_lai    時間: 4 天前 19:26

回復  GBKEE

GBKEE大,如果目前工作表裡面沒有SHEET1和SHEET2,怎辦?
因為我在做測試的時候砍光了SHEE ...
paul3063 發表於 2018-1-17 17:06


只剩下SHEET13,直接將 SHEET13 表單名稱改成 SHEET1 便可以了,以此類推。
作者: jackyq    時間: 4 天前 19:29

還真是慢呀

剛有試過一個方法
可以把倒進 sheet 的耗時降到 1/6
不過原碼沒有提供 倒進多sheet
作者: jackyq    時間: 4 天前 19:46

本帖最後由 jackyq 於 2018-1-17 19:58 編輯

Public Sub 扁我______()
   
    Dim rsData As Object

    Csv = "C:\Documents and Settings\Administrator\My Documents\Downloads\36_2.csv\36_2.csv"   ' 自己改成檔案真實路徑

    Set rsData = Get_CSVFile_Object(Csv)
   
   
    每頁承載筆數 = 10000
    page_count = (rsData.RecordCount \ 每頁承載筆數) + Sgn(rsData.RecordCount Mod 每頁承載筆數)
   
    For w = 1 To page_count
        On Error Resume Next
        s = Sheets("Data_" & w).Name
        If Err Then
           Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Data_" & w
        End If
        On Error GoTo 0
        Sheets("Data_" & w).Cells.Clear
    Next
    Excel.Application.DisplayAlerts = 0
    On Error Resume Next
    For w = page_count + 1 To 10 ^ 9
        Sheets("Data_" & w).Delete
        If Err Then Exit For
    Next
    On Error GoTo 0
    Excel.Application.DisplayAlerts = 1

    If rsData.RecordCount > 0 Then
        ReDim 標題(0 To rsData.Fields.Count) As String
        For w = 0 To rsData.Fields.Count - 1
            標題(w) = rsData.Fields(w).Name
        Next

        For page = 1 To page_count
            Sheets("Data_" & page).Select
            Sheets("Data_" & page).Cells(1, 1).Resize(, UBound(標題) - LBound(標題) + 1) = 標題


            Table = rsData.GetRows(每頁承載筆數)
            Table = Transpose2(Table)
            Sheets("Data_" & page).Cells(2, 1).Resize(UBound(Table, 1) - LBound(Table, 1) + 1, UBound(Table, 2) - LBound(Table, 2) + 1) = Table
        Next
    End If
    rsData.Close

End Sub

Public 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, "", ""
   
    Const adOpenStatic = 3, adLockReadOnly = 1, adCmdText = 1
   
    rs.Open "select * from [" & strFileName & "]", conn, adOpenStatic, adLockReadOnly, adCmdText
    Set Get_CSVFile_Object = rs
End Function


Public Function Transpose2(ar2d)
    Dim c1 As Long, c2 As Long
    ReDim out(LBound(ar2d, 2) To UBound(ar2d, 2), LBound(ar2d, 1) To UBound(ar2d, 1)) As String
    For c1 = LBound(ar2d, 1) To UBound(ar2d, 1)
    For c2 = LBound(ar2d, 2) To UBound(ar2d, 2)
        If Not IsNull(ar2d(c1, c2)) Then
           out(c2, c1) = ar2d(c1, c2)
        End If
    Next
    Next
    Transpose2 = out
End Function
作者: jackyq    時間: 4 天前 19:49

快速倒進 sheet
因沒有提供 倒進 >= sheet2 ...  
所以就不弄這個了
作者: GBKEE    時間: 3 天前 17:00

回復 11# paul3063

8#這段程式碼就是 處理工作表不存在 ,請練習看看
  1. XER:
  2.     Dim ii
  3.      '處理程式中 Sheets(i).Cells.Clear ˇ的錯誤
  4.     If Err = 9 Then ThisWorkbook.Sheets.Add , Sheets(Sheets.Count): Resume
  5.      '處理程式中 .Resize(, UBound(Ar) + 1) = Ar ˇ的錯誤
  6.    '2003 **陣列的元素字元數大於255 個字元,會有錯誤
  7.    '2003 以後的版本沒有此錯誤
  8.     For ii = 0 To UBound(Ar)
  9.         Sheets(Sh).Cells(i + Sh - X, ii + 1) = Ar(ii)
  10.         If Len(Ar(ii)) > 456 Then
  11.         Debug.Print Sh, i + 1 - X, ii, Len(Ar(ii))
  12.         End If
  13.     Next
  14.     Resume Next
複製代碼

作者: GBKEE    時間: 3 天前 17:11

回復 14# jackyq
2003 版
Public Sub 扁我______() 對照  #8 的 Sub Ex_CVS的分割()  中 找出一些差異


[Book1]Sheet1!$L$979 字元數1000        [Book1]Sheet3!$L$3692 字元數1000
[Book1]Sheet1!$L$2160 字元數1000        [Book1]Sheet3!$L$3693 字元數1000
[Book1]Sheet1!$L$2161 字元數1000        [Book1]Sheet3!$M$5833 字元數988
[Book1]Sheet1!$Q$2529 字元數1042        [Book1]Sheet3!$M$5834 字元數988
[Book1]Sheet2!$M$3438 字元數988        [Book1]Sheet3!$L$6259 字元數1000
[Book1]Sheet2!$M$3474 字元數988        [Book1]Sheet3!$L$6260 字元數1000
[Book1]Sheet2!$AD$4019 字元數1058        [Book1]Sheet3!$Q$6409 字元數1067
[Book1]Sheet2!$M$4027 字元數988        [Book1]Sheet3!$M$7768 字元數988
[Book1]Sheet2!$M$4083 字元數988        [Book1]Sheet3!$M$9390 字元數988
[Book1]Sheet2!$AD$4090 字元數1058        [Book1]Sheet3!$M$9391 字元數988
[Book1]Sheet2!$M$4578 字元數988        [Book1]Sheet4!$Q$2957 字元數1067
[Book1]Sheet2!$M$4615 字元數988        [Book1]Sheet4!$Q$3005 字元數1067
[Book1]Sheet2!$M$4618 字元數988        [Book1]Sheet4!$Q$4840 字元數1028
[Book1]Sheet2!$M$4703 字元數988        [Book1]Sheet4!$Q$4841 字元數1028
[Book1]Sheet2!$M$4909 字元數988        [Book1]Sheet4!$Q$8504 字元數1028
[Book1]Sheet2!$M$4910 字元數988        [Book1]Sheet5!$AC$2302 字元數1759
[Book1]Sheet2!$M$4942 字元數988        [Book1]Sheet5!$AA$9490 字元數1282
[Book1]Sheet2!$M$4943 字元數988        [Book1]Sheet6!$Q$5208 字元數1204
[Book1]Sheet2!$AD$5049 字元數1058        [Book1]Sheet6!$Q$5563 字元數1024
[Book1]Sheet2!$AD$5050 字元數1058        [Book1]Sheet7!$AD$1329 字元數1058
[Book1]Sheet2!$AD$7966 字元數1759        [Book1]Sheet7!$AB$1333 字元數1058
[Book1]Sheet2!$AB$9480 字元數1759        [Book1]Sheet7!$AA$5423 字元數945
[Book1]Sheet2!$Q$9482 字元數1024
作者: paul3063    時間: 昨天 22:34

回復 17# GBKEE

謝謝大家




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)