帖子: 32
主題: 9
精華: 0
積分: 122
點名: 0
作業系統: WINXP
軟體版本: Office XP
閱讀權限: 20
性別: 男
註冊時間: 2010-5-14
最後登錄: 2024-3-20

1^# 跳轉到 » 正序看帖

字體大小: tT

發表於 2011-5-27 12:39 | 只看該作者

[發問] 如何將超過65536筆以上的資料放入活頁簿(已解決^^)

本帖最後由巴克斯於 2011-5-28 09:06 編輯

EX:
文字檔: test.txt (筆數會超過65536,總筆數:未知)

希望程式依序將65536筆資料放入各工作表
sheet1 1-65536筆
sheet2 65537-131072筆
sheet3 ...以此類推到最末筆

請教須如何做較快速?

樓主熱帖

巴克斯

中學生 Rank: 2

帖子: 32
主題: 9
精華: 0
積分: 122
點名: 0
作業系統: WINXP
軟體版本: Office XP
閱讀權限: 20
性別: 男
註冊時間: 2010-5-14
最後登錄: 2024-3-20

6^#

發表於 2011-5-28 09:05 | 只看該作者

謝謝兩位板主的幫忙
兩種方式都成功了
比我原來土法煉鋼快速很多
也學習到精簡的程式寫法
^^

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

5^#

發表於 2011-5-28 08:03 | 只看該作者

回復 4# 巴克斯
Sub yy()
'引用Microsoft Scripting Runtime

不引用Microsoft Scripting Runtime的寫法

Sub Ex()
Dim MyString As String, i As Long, Sh As Integer, Ar
Open "d:\test\test.txt" For Input As #1 ' 開啟輸入檔。
i = 1
Sh = 1
ReDim Ar(1 To Rows.Count)
Do While Not EOF(1) ' 檢查是否已到檔尾。
If i > Rows.Count Then 'Rows.Count為列的總數 2003版本->65536
Sheets(Sh).Range("a:a") = Application.Transpose(Ar)
ReDim Ar(1 To Rows.Count)
i = 1
Sh = Sh + 1
If Sh > Sheets.Count Then Sheets.Add after:=Sheets(Sheets.Count)
End If
Line Input #1, MyString ' 將資料讀入變數中。
Ar(i) = MyString
i = i + 1
Loop
Sheets(Sh).Range("a:a") = Application.Transpose(Ar)
Close #1
End Sub

複製代碼

TOP

巴克斯

中學生 Rank: 2

帖子: 32
主題: 9
精華: 0
積分: 122
點名: 0
作業系統: WINXP
軟體版本: Office XP
閱讀權限: 20
性別: 男
註冊時間: 2010-5-14
最後登錄: 2024-3-20

4^#

發表於 2011-5-28 06:06 | 只看該作者

本帖最後由巴克斯於 2011-5-28 09:03 編輯

謝謝版主回覆
執行後發生錯誤訊息
編譯錯誤: 使用者自訂型態尚未定義

偵錯為
Dim fso As Scripting.FileSystemObject
Dim myTxt As Scripting.TextStream

麻煩版主看看是否可修訂,謝謝

TOP

oobird

　頭銜: 街友一族

超級版主 Rank: 8 Rank: 8

帖子: 1572
主題: 16
精華: 2
積分: 1521
點名: 0
作業系統: xp
軟體版本: office 2003
閱讀權限: 150
性別: 男
註冊時間: 2010-5-1
最後登錄: 2016-1-13

論壇貢獻勳章

3^#

發表於 2011-5-27 14:07 | 只看該作者

Sub yy()
'引用Microsoft Scripting Runtime
Application.ScreenUpdating = False
Dim fso As Scripting.FileSystemObject
Dim myTxt As Scripting.TextStream
Dim myfile As String, myname$
Dim i As Long, j%
ActiveSheet.Cells.Clear
myfile = Application.GetOpenFilename("text files (*.txt),*.txt", , "記事本文件") '選擇文件名
Set fso = New Scripting.FileSystemObject
Set myTxt = fso.OpenTextFile(Filename:=myfile, IOMode:=ForReading)
With myTxt
i = 1: j = 1: myname = "sheet" & j
Do Until .AtEndOfStream
Sheets(myname).Cells(i, 1) = .ReadLine
i = i + 1
If i = 65530 Then
j = j + 1
If j > 3 Then
Sheets.Add after:=Sheets(myname)
End If
myname = "sheet" & j
i = 1
End If
Loop
.Close
End With
End Sub

複製代碼

沒文件可測試，你自己測試一下吧

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2011-5-27 12:52 | 只看該作者

回復 1# 巴克斯
可否傳上筆數少於65536 的程式碼,來看看如何改.

TOP