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

朱子

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

下載 (62.55 KB)

2020-2-14 17:38

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

下載 (183.46 KB)

2020-2-14 17:43

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

檔案連結如下
date.zip (648 Bytes)

下載次數: 4

2020-2-14 17:45

准提部林

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)

下載次數: 4

2020-2-15 13:19

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

朱子

回復 2# 准提部林
很感謝您幫忙我解決問題，但是我的資料筆數很多，之前放在網路的檔案是精簡版，實際上我有近3000筆資料要轉換
我發現我無法用該程式碼轉換近3000筆資料，VBA一直出現如下圖錯誤訊息

下載 (71.31 KB)

2020-2-17 13:22

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

下載次數: 5

2020-2-17 15:26

朱子

回復 2# 准提部林
很感謝您幫忙我解決問題，但是我的資料筆數很多，之前放在網路的檔案是精簡版，實際上我有近3000筆資料要轉換
我發現我無法用該程式碼轉換近3000筆資料，VBA一直出現如下圖錯誤訊息
[attach]31732[/attach]

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

准提部林

回復 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


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