返回列表 上一主題 發帖

[發問] 如何將特定幾行內容轉成欄位重複

朱子

帖子
3 
主題
1 
精華
0 
積分
5 
點名
0  
作業系統
Window 7 
軟體版本
Office 2013 
閱讀權限
10 
性別
女 
註冊時間
2020-2-14 
最後登錄
2020-2-17 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2020-2-14 17:46 | 只看該作者

[發問] 如何將特定幾行內容轉成欄位重複

我有一個純文字檔，檔案格式如下圖

請問我要如何寫VBA程式，可以把標準別那一行，轉成單欄儲存。
格式如下

因為分類太多，希望能寫VBA程式幫忙解決

檔案連結如下
date.zip (648 Bytes)
收藏 分享

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-27 
2#
發表於 2020-2-15 13:19 | 只看該作者
Sub 匯入()
Dim xFile$, TxtStr$, T$, TR, Arr, i&, N&
Intersect(ActiveSheet.UsedRange, [A:G]).Offset(1, 0).EntireRow.Delete
xFile = ThisWorkbook.Path & "\date.txt"
With CreateObject("ADODB.Stream")
     .Charset = "UTF-8"
     .Open
     .LoadFromFile xFile
      TxtStr = .ReadText
      .Close
End With
TR = Split(TxtStr, vbCrLf)
ReDim Arr(1 To UBound(TR), 1 To 7)
For i = 0 To UBound(TR)
    If Len(TR(i)) < 2 Then GoTo 101
    If Left(TR(i), 6) = "標 準 別：" Then T = Mid(TR(i), 7): GoTo 101
    If T = "" Then GoTo 101
    N = N + 1
    Arr(N, 1) = T '標準別
    Arr(N, 2) = Trim(Evaluate("MidB(""" & TR(i) & """, 1, 10)")) '處置代碼
    Arr(N, 3) = Trim(Evaluate("MidB(""" & TR(i) & """, 11, 30)")) '處置名稱
    Arr(N, 4) = Trim(Evaluate("MidB(""" & TR(i) & """, 41, 10)")) '成本中心
    Arr(N, 5) = Trim(Evaluate("MidB(""" & TR(i) & """, 51, 10)")) '處置類別
    Arr(N, 6) = Trim(Evaluate("MidB(""" & TR(i) & """, 61, 10)")) '健保單價
    Arr(N, 7) = Trim(Evaluate("MidB(""" & TR(i) & """, 71, 10)")) '自費單價
101: Next i
If N > 0 Then [A2].Resize(N, 7) = Arr
End Sub

測試檔:
文字檔轉Excel.rar (11.77 KB)



======================================

TOP

朱子

帖子
3 
主題
1 
精華
0 
積分
5 
點名
0  
作業系統
Window 7 
軟體版本
Office 2013 
閱讀權限
10 
性別
女 
註冊時間
2020-2-14 
最後登錄
2020-2-17 
3#
發表於 2020-2-17 15:27 | 只看該作者
回復 2# 准提部林
很感謝您幫忙我解決問題，但是我的資料筆數很多，之前放在網路的檔案是精簡版，實際上我有近3000筆資料要轉換
我發現我無法用該程式碼轉換近3000筆資料，VBA一直出現如下圖錯誤訊息


我看不出來要怎樣修正程式碼才能正確匯入
重新附上新的檔案，裡面有300筆資訊
data2.zip (6.77 KB)

TOP

朱子

帖子
3 
主題
1 
精華
0 
積分
5 
點名
0  
作業系統
Window 7 
軟體版本
Office 2013 
閱讀權限
10 
性別
女 
註冊時間
2020-2-14 
最後登錄
2020-2-17 
4#
發表於 2020-2-17 15:28 | 只看該作者
回復 2# 准提部林
很感謝您幫忙我解決問題，但是我的資料筆數很多，之前放在網路的檔案是精簡版，實際上我有近3000筆資料要轉換
我發現我無法用該程式碼轉換近3000筆資料，VBA一直出現如下圖錯誤訊息
[attach]31732[/attach]

我看不出來要怎樣修正程式碼才能正確匯入
重新附上新的檔案，裡面有300筆資訊
[attach]31733[/attach]

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-27 
5#
發表於 2020-2-18 14:57 | 只看該作者
回復 3# 朱子
Sub 匯入()
Dim xFile$, TxtStr$, T$, TR, Arr, i&, N&
Intersect(ActiveSheet.UsedRange, [A:G]).Offset(1, 0).EntireRow.Delete
xFile = ThisWorkbook.Path & "\data2.txt"
With CreateObject("ADODB.Stream")
     .Charset = "UTF-8"
     .Open
     .LoadFromFile xFile
      TxtStr = .ReadText
      .Close
End With
TR = Split(TxtStr, vbCrLf)
ReDim Arr(1 To UBound(TR), 1 To 7)
For i = 0 To UBound(TR)
    If Len(TR(i)) < 2 Then GoTo 101
    If Left(TR(i), 6) = "標 準 別：" Then T = Mid(TR(i), 7): GoTo 101
    If T = "" Then GoTo 101
    N = N + 1
    TR(i) = Replace(TR(i), """", "|")
    Arr(N, 1) = T '標準別
    Arr(N, 2) = Trim(Evaluate("MidB(""" & TR(i) & """, 1, 10)")) '處置代碼
    Arr(N, 3) = Replace(Trim(Evaluate("MidB(""" & TR(i) & """, 11, 30)")), "|", """") '處置名稱
    Arr(N, 4) = Trim(Evaluate("MidB(""" & TR(i) & """, 41, 10)")) '成本中心
    Arr(N, 5) = Trim(Evaluate("MidB(""" & TR(i) & """, 51, 10)")) '處置類別
    Arr(N, 6) = Trim(Evaluate("MidB(""" & TR(i) & """, 61, 10)")) '健保單價
    Arr(N, 7) = Trim(Evaluate("MidB(""" & TR(i) & """, 71, 10)")) '自費單價
101: Next i
If N > 0 Then [A2].Resize(N, 7) = Arr
End Sub


'===============================

TOP

        靜思自在 : 【時日莫空過】一個人在世間做了多少事，就等於壽命有多長。因此必須與時間競爭，切莫使時日空過。
返回列表 上一主題