麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 如何在不打開檔案下，將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秒
試試看

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

複製代碼

作者: paul3063 時間: 2018-1-16 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 時間: 2018-1-17 11:12

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

回復 9# paul3063

QueryTable 是沒有終止列這屬性
你的程式碼在2003運行還是受到65536列的限制
如圖
[attach]28251[/attach]
修改程式看看 2003,2010 的差異

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

複製代碼

作者: paul3063 時間: 2018-1-17 17:06

回復 10# GBKEE

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

作者: c_c_lai 時間: 2018-1-17 19:26

回復 GBKEE

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

只剩下SHEET13，直接將 SHEET13 表單名稱改成 SHEET1 便可以了，以此類推。

作者: jackyq 時間: 2018-1-17 19:29

還真是慢呀

剛有試過一個方法
可以把倒進 sheet 的耗時降到 1/6
不過原碼沒有提供倒進多sheet

作者: jackyq 時間: 2018-1-17 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 時間: 2018-1-17 19:49

快速倒進 sheet
因沒有提供倒進 >= sheet2 ...
所以就不弄這個了

作者: GBKEE 時間: 2018-1-18 17:00

回復 11# paul3063

8#這段程式碼就是處理工作表不存在 ,請練習看看

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(i + Sh - X, ii + 1) = Ar(ii)
If Len(Ar(ii)) > 456 Then
Debug.Print Sh, i + 1 - X, ii, Len(Ar(ii))
End If
Next
Resume Next

複製代碼

作者: GBKEE 時間: 2018-1-18 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 時間: 2018-1-20 22:34

回復 17# GBKEE

謝謝大家

作者: 7777 時間: 2019-3-31 16:06

回復 17# GBKEE

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

我也有上述問題，爬文後，因程度不足無法解決處理
想請問
如何將網頁
http://financials.morningstar.com/ratios/r.html?t=UNP
中的UNP Key Ratios.CSV檔，(圖)

不打開.CSV檔，抓出資料放置在a1
請大大撥冗幫忙 ...感恩謝謝

[attach]30340[/attach]

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