返回列表 上一主題 發帖

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

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

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

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

TOP

回復 2# jackyq


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

TOP

本帖最後由 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

TOP

回復 3# paul3063

把資料分派到 sheet1 , sheet2 ..

勞煩大大自己處裡

TOP

回復 5# jackyq


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

TOP

回復 6# paul3063

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

TOP

本帖最後由 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 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

TOP

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

回復 9# paul3063

QueryTable 是沒有終止列這屬性
你的程式碼在2003運行還是受到65536列的限制
如圖
未命名.jpg
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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 看別人不順眼,是自己修養不夠。
返回列表 上一主題