Board logo

標題: [發問] 如何將特定幾行內容轉成欄位重複 [打印本頁]
作者: 朱子    時間: 2020-2-14 17:46     標題: 如何將特定幾行內容轉成欄位重複

我有一個純文字檔，檔案格式如下圖
[attach]31713[/attach]
請問我要如何寫VBA程式，可以把標準別那一行，轉成單欄儲存。
格式如下
[attach]31714[/attach]
因為分類太多，希望能寫VBA程式幫忙解決

檔案連結如下
[attach]31715[/attach]
作者: 准提部林    時間: 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

測試檔:
[attach]31721[/attach]



======================================
作者: 朱子    時間: 2020-2-17 15:27

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

我看不出來要怎樣修正程式碼才能正確匯入
重新附上新的檔案，裡面有300筆資訊
[attach]31733[/attach]
作者: 朱子    時間: 2020-2-17 15:28

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

我看不出來要怎樣修正程式碼才能正確匯入
重新附上新的檔案，裡面有300筆資訊
[attach]31733[/attach]
作者: 准提部林    時間: 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


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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)