- 帖子
- 323
- 主題
- 6
- 精華
- 0
- 積分
- 313
- 點名
- 0
- 作業系統
- xp
- 軟體版本
- 2k
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2015-6-24
- 最後登錄
- 2025-5-3
|
14#
發表於 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 |
|
發表於 2018-1-18 17:11
| 
