12
返回列表 上一主題 發帖

請問如何將存檔如表格一樣

wufonna

帖子
161 
主題
26 
精華
0 
積分
187 
點名
0  
作業系統
xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
來自
TW 
註冊時間
2011-1-2 
最後登錄
2022-2-16 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2014-9-19 20:40 | 只看該作者

請問如何將存檔如表格一樣

請問如何將存檔如表格一樣
  1. Sub Trans()
  2.     Dim myDir As String, myRng As Range
  3.     Dim i As Integer
  4.     myDir = ThisWorkbook.Path '指定路徑為工作表所在目錄
  5.     ChDrive myDir
  6.     ChDir myDir
  7.     Set myRng = Range("A1").CurrentRegion '定義要抓取的範圍
  8.    
  9.     Dim MyTxt As String

  11.     Dim filename As String
  12.     '定義檔名為時間
  13.     filename = Format(Now(), "yyyymmddhhmmss") & ".txt"
  14.     '開啟檔案寫入，若路徑中未有該檔案會create一個
  15.     Open filename For Output As #1
  16.     '第一列不抓進來，一直取到最後一列
  17.     For i = 1 To myRng.Rows.Count
  18.         MyTxt = myRng.Cells(i, 1).Text + myRng.Cells(i, 2).Text + myRng.Cells(i, 3).Text + myRng.Cells(i, 4).Text + myRng.Cells(i, 5).Text
  19.         Print #1, MyTxt
  20.         
  21.     Next
  22.     Close #1
  23.     MsgBox ("存檔成功! ")
  24. End Sub
複製代碼
如下圖一樣，謝謝

2014-09-19_203402.jpg (37.84 KB)

2014-09-19_203402.jpg

testtxt.rar (14.34 KB)

收藏 分享

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
16  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
2#
發表於 2014-9-20 05:45 | 只看該作者
請問如何將存檔如表格一樣如下圖一樣，謝謝
wufonna 發表於 2014-9-19 20:40
  1. Sub Trans()
  2.     Dim myRng As Range
  3.     Dim i%, j%
  4.     Dim MyTxt$, filename$
  5.     Dim aLen()
  6.    
  7.     aLen = Array(8, 16, 16, 16, 16, 16, 16)
  8.     Set myRng = Range("A1").CurrentRegion '定義要抓取的範圍
  9.    
  10.     '定義檔名為時間
  11.     filename = ThisWorkbook.Path & "\" & Format(Now(), "yyyymmddhhmmss") & ".txt"
  12.     '開啟檔案寫入，若路徑中未有該檔案會create一個
  13.     Open filename For Output As #1
  14.     '第一列不抓進來，一直取到最後一列
  15.     With myRng
  16.     For i = 1 To .Rows.Count
  17.       MyTxt = ""
  18.       For j = 1 To 7
  19.         MyTxt = MyTxt & Left(.Cells(i, j) & Space(16), aLen(j - 1) - Len(.Cells(i, j)) * -(i = 1))
  20.       Next
  21.         Print #1, MyTxt
  22.     Next
  23.     End With
  24.     Close #1
  25.     MsgBox ("存檔成功! ")
  26. End Sub
複製代碼
testtxt-a.zip (14.25 KB)

TOP

wufonna

帖子
161 
主題
26 
精華
0 
積分
187 
點名
0  
作業系統
xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
來自
TW 
註冊時間
2011-1-2 
最後登錄
2022-2-16 
3#
發表於 2014-9-20 19:00 | 只看該作者
回復 2# luhpro


    謝謝 luhpro 大大 ，程式可執行 ^_^
  諸問 大大          MyTxt = MyTxt & Left(.Cells(i, j) & Space(16), aLen(j - 1) - Len(.Cells(i, j)) * -(i = 1))
中的  *-(i = 1) 的作用
謝謝

TOP

bobomi

帖子
181 
主題
5 
精華
0 
積分
197 
點名
0  
作業系統
XP 
軟體版本
2000 
閱讀權限
20 
性別
女 
註冊時間
2014-3-9 
最後登錄
2024-4-29 
4#
發表於 2014-9-20 19:09 | 只看該作者
本帖最後由 bobomi 於 2014-9-20 19:10 編輯

a =  -(i = 1)  
當 i = 1 時,         a = 1
當 i = 其他值 時, a = 0

b = Len(.Cells(i, j)) * a  ->  當 i = 1 時,  b = Len(.Cells(i, j)) * 1 = Len(.Cells(i, j))
b = Len(.Cells(i, j)) * a  ->  當 i = 其他值 時,  b =  Len(.Cells(i, j)) * 0 = 0

意即用數學式取代 IF or IIF

IF i = 1 then
   b = Len(.Cells(i, j))
else
  b = 0
end if

TOP

wufonna

帖子
161 
主題
26 
精華
0 
積分
187 
點名
0  
作業系統
xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
來自
TW 
註冊時間
2011-1-2 
最後登錄
2022-2-16 
5#
發表於 2014-9-20 22:24 | 只看該作者
本帖最後由 wufonna 於 2014-9-20 22:27 編輯

回復 4# bobomi


    請問大大
a =  -(i = 1)  
當 i = 1 時,         a = 1
當 i = 其他值 時, a = 0

當=1
debug
i=1 是 True
i 不是 1
i = 1 是 flase

而
i=1  -(i = 1)  是 1
i 不是 1  -(i = 1) 是 0
謝謝

意即用數學式取代 IF or IIF

IF i = 1 then
   b = Len(.Cells(i, j))
else
  b = 0
end if

原來是這樣
沒看清楚
謝謝 大大

TOP

bobomi

帖子
181 
主題
5 
精華
0 
積分
197 
點名
0  
作業系統
XP 
軟體版本
2000 
閱讀權限
20 
性別
女 
註冊時間
2014-3-9 
最後登錄
2024-4-29 
6#
發表於 2014-9-20 22:53 | 只看該作者
本帖最後由 bobomi 於 2014-9-20 22:55 編輯

vba 的 True  其實就是 = -1
vba 的 False  其實就是 = 0

-(i = 1)  = - True = - (-1) = 1

TOP

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
16  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
7#
發表於 2014-9-21 18:52 | 只看該作者
回復  luhpro
    謝謝 luhpro 大大 ，程式可執行 ^_^
  諸問 大大          MyTxt = MyTxt & Left( ...  , aLen(j - 1) - Len(.Cells(i, j)) * -(i = 1))
wufonna 發表於 2014-9-20 19:00

之所以需要多這一段是因為在 Excel VBA 中, 中文(雙位元字組 - 全形字) 在某些函數的計算上只佔一個字的寬度
Len("年度")=2
但在文字檔中與其占據相同空間的英數字(單位元字組 - 半形字) :
Len("2014") 卻是 =4
所以當顯示中文字時,
為了要使其與英文字的位置能夠對齊,
往往需要再減掉與中文字數相同的半形字空格.

而這也往往會使得使用全形字的文件在做定位處理時很不方便,
例如一個文件 :
王OO  男  工程師 台北市OO區OOOO路二段000巷00號2樓之一 (02)1234-5678
蘇OO  女               新竹市OO區OO路00號                                         (05)000-0000
在地址的中文字數不定,
若又有些欄位可能是完全空白的情形下, (這就不適合以空白來做欄位區隔)
如上方例子若想要定位後面的電話就要經過較複雜的計算處理了.

在 Mid 與 Left 等函數也是有這樣的情形,
弔詭的是 "儲存格函數" 中有群 LenB, LeftB 與 MIDB 等可以直接處理雙位元字組的字數定位處理, ( LenB("年度")=4 )
Excel VBA 這種更需要這類處理的語言(讀取文字檔之類的...),
我找了很久都找不到類似的函數可用,
也不知道其他人都是怎樣處理類似問題的.

TOP

wufonna

帖子
161 
主題
26 
精華
0 
積分
187 
點名
0  
作業系統
xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
來自
TW 
註冊時間
2011-1-2 
最後登錄
2022-2-16 
8#
發表於 2014-9-22 15:05 | 只看該作者
回復 7# luhpro
回復 6# bobomi

謝謝 bobomi  大 luhpro 大
參考站上的資料 http://forum.twbts.com/thread-31-1-1.html  用 StrConv 是否那要改進的 謝謝
  1. Sub Test()
  2. GetDividend ("2002")
  3. '取得網頁表格格式化為文字表格
  4. End Sub
  5. Private Sub GetDividend(ByVal ss As String) '取股利網頁
  6. Set ie = CreateObject("internetexplorer.application") '使用此方式可以免除 "設定引用項目"

  8. Dim hh As String, T As Date, i, ii, S As Object
  9. Dim filename As String, varVar As String

  11. T = Time
  12. hh = "http://dj.mybank.com.tw/z/zc/zcc/zcc_" & ss & ".asp.htm"
  13. With ie
  14. .Navigate hh
  15. Do While .readyState <> 4 '等待網頁下載完畢
  16. DoEvents
  17. If Time >= T + #12:00:03 AM# Then '等待8秒 3秒太少會誤錯改8妙
  18. DoEvents
  19. Application.SendKeys "~" '股票代號錯誤,網頁會有訊息,須按確定,才可繼續下面股票代號

  21. Exit Do
  22. End If
  23. Loop
  24. ''***不是等待8秒 3秒太少會誤錯改8妙 ***
  25. Do
  26. Set S = .Document.getElementsByTagName("table")(3) '
  27. Loop Until Not S Is Nothing
  28. '*** 勝一 沒捉到 ????
  29. '*** 因程式運行太快 , S Is Nothing, S 尚未指定為.Document.getElementsByTagName("table")(4)
  30. '*** 程式已經執行下一行, With 工作表2 的程式碼
  31. filename = ss & "_" & Format(Now(), "yyyymmddhhmmss") & ".txt"
  32. Open filename For Output As #1
  33. For i = 0 To S.Rows.Length - 1 '寫入資料
  34. varVar = ""
  35. For ii = 0 To S.Rows(i).Cells.Length - 1 ' S.Rows(i).Cells.Length - 1 才是正確
  36. varVar = varVar & Left(S.Rows(i).Cells(ii).innerText & Space(16), 12 - (LenB(StrConv(S.Rows(i).Cells(ii).innerText, vbFromUnicode)) - Len(S.Rows(i).Cells(ii).innerText)))
  37. 'http://forum.twbts.com/thread-31-1-1.html Len / LenB - 字串長度判斷方式的探討
  38. DoEvents
  39. Next
  40. Print #1, varVar

  42. Next
  43. Close #1

  45. ' MsgBox ("存檔成功! ")
  46. End With
  47. End Sub
複製代碼

TOP

wufonna

帖子
161 
主題
26 
精華
0 
積分
187 
點名
0  
作業系統
xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
來自
TW 
註冊時間
2011-1-2 
最後登錄
2022-2-16 
9#
發表於 2014-9-22 18:34 | 只看該作者
請問 大大
這網頁有個換行
我多加了
varVar = Replace(varVar, Chr(10), " ") '取代換行為空格
文字檔內還有1 個黑格
請問大大是那裡有錯
謝謝
  1. Sub Test()
  2. GetDividend ("2002")
  3. '取得網頁表格格式化為文字表格
  4. End Sub
  5. Private Sub GetDividend(ByVal ss As String) '取股利網頁
  6. Set ie = CreateObject("internetexplorer.application") '使用此方式可以免除 "設定引用項目"

  8. Dim hh As String, T As Date, i, ii, S As Object
  9. Dim filename As String, varVar As String

  11. T = Time
  12. ' hh = "http://dj.mybank.com.tw/z/zc/zcc/zcc_" & ss & ".asp.htm"
  13. hh = "http://yamstock.megatime.com.tw/asp/stockinfo/GetReport.asp?select_table=html\Finain_Full\&stockid=" & ss & "&name1=D5&index1=5"

  15. With ie
  16. .Navigate hh
  17. Do While .readyState <> 4 '等待網頁下載完畢
  18. DoEvents
  19. If Time >= T + #12:00:03 AM# Then '等待8秒 3秒太少會誤錯改8妙
  20. DoEvents
  21. Application.SendKeys "~" '股票代號錯誤,網頁會有訊息,須按確定,才可繼續下面股票代號


  24. Exit Do
  25. End If
  26. Loop
  27. ''***不是等待8秒 3秒太少會誤錯改8妙 ***
  28. Do
  29. Set S = .Document.getElementsByTagName("table")(4) '
  30. Loop Until Not S Is Nothing
  31. '*** 勝一 沒捉到 ????
  32. '*** 因程式運行太快 , S Is Nothing, S 尚未指定為.Document.getElementsByTagName("table")(4)
  33. '*** 程式已經執行下一行, With 工作表2 的程式碼
  34. filename = ss & "_" & Format(Now(), "yyyymmddhhmmss") & ".txt"
  35. Open filename For Output As #1
  36. For i = 0 To S.Rows.Length - 1 '寫入資料
  37. varVar = ""
  38. For ii = 0 To S.Rows(i).Cells.Length - 1 ' S.Rows(i).Cells.Length - 1 才是正確
  39. varVar = varVar & Left(S.Rows(i).Cells(ii).innerText & Space(14), 14 - (LenB(StrConv(S.Rows(i).Cells(ii).innerText, vbFromUnicode)) - Len(S.Rows(i).Cells(ii).innerText)))
  40. 'http://forum.twbts.com/thread-31-1-1.html Len / LenB - 字串長度判斷方式的探討
  41. varVar = Replace(varVar, Chr(10), " ")
  42. DoEvents
  43. Next
  44. Print #1, varVar

  46. Next
  47. Close #1

  49. ' MsgBox ("存檔成功! ")
  50. End With
  51. End Sub
複製代碼

TOP

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
16  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2024-11-14 
10#
發表於 2014-9-22 23:49 | 只看該作者
本帖最後由 luhpro 於 2014-9-23 00:00 編輯
請問 大大
這網頁有個換行
我多加了
varVar = Replace(varVar, Chr(10), " ") '取代換行為空格
文字檔內還有1 個黑格...
wufonna 發表於 2014-9-22 18:34

你是指標題列中 年度與季別間有兩個空格嗎?
其實這個你可以用手動剪貼一下就可以發現:
1.網頁中複製該表格內容
2.貼到 Excel
3. 再複製Excel上的表格
4. 貼到記事本
用方向鍵移動游標,
你會發現年度那列中各年度間游標有時會一次跳很多格,
我判斷那是 HT (Tab按鍵) Chr(9) 字元,
你試試看用空字元取代應該就不會發生了.

TOP

        靜思自在 : 一個缺口的杯子，如果換一個角度看它，它仍然是圓的。
12
返回列表 上一主題