返回列表 上一主題 發帖

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

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

我有一個純文字檔,檔案格式如下圖
z.jpg
2020-2-14 17:38

請問我要如何寫VBA程式,可以把標準別那一行,轉成單欄儲存。
格式如下
b.jpg
2020-2-14 17:43

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

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

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

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


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

TOP

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

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

TOP

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

        靜思自在 : 得理要饒人,理直要氣和。
返回列表 上一主題