kulisung

回復 10# Hsieh


    感謝回覆，小弟知道拉寬資料都會顯示出來
    那若要將該列的值分為分欄排放（非分列）
    程式是否會因為少了判斷值而無法達成？
    因為欄位名稱都一樣，所以造成位置的指定都相同
    （小弟這樣的想法可對？)

GBKEE

回復 11# kulisung
為何不上傳,文字檔,轉置後的excel範例檔,可以一目了然你的問題.

kulisung

回復 12# GBKEE

不好意思，文字檔就如前面所列3筆，原想擷取此3筆資料應該足夠（實際上千筆）
另外原本是想上傳excel結果，但是附件格式不允許？只好上傳圖片
而剛剛才發現可以上傳zip檔，真不好意思
不過就如前面的圖片所說的那樣
最後轉出結果因欄位名稱相同，所以會將資料內容皆放在同一儲存格
現在是希望能區隔開，只是依自己想法去判斷似乎是會很麻煩？
若造成困擾小弟在這說聲抱歉
test.zip (18.22 KB)

下載次數: 4

2013-7-3 22:24

kulisung

回復 13# kulisung


重新上傳一次壓縮檔
上面那個檔案沒有更新到部份說明
test.zip (18.75 KB)

下載次數: 8

2013-7-3 22:35

GBKEE

回復 14# kulisung
試試看

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Txt As String, Fs As Object, d, A(), Tile As String, S As String, Stile As String, i, ii As Integer
   
4.     Txt = "d:\logfile.log" '文字檔目錄
   
5.     Set Fs = CreateObject("Scripting.FileSystemObject").OpenTextFile(Txt, 1)
   
6.     'OpenTextFile 方法 開啟一個指定的檔案並傳回一個 TextStream 物件，該物件可用於對檔案進行讀取或附加。
   
7.     d = Split(Fs.readall, Chr(10))
   
8.     Fs.Close                                                                    '關閉文字檔
   
9.     For i = 0 To UBound(d)
   
10.         If InStr(d(i), "---") Then
    
11.             If S <> "" Then
    
12.                 If Len(Stile) > Len(Tile) Then Tile = Stile                     '確定欗位標頭
    
13.                ReDim Preserve A(0 To ii)
    
14.                A(ii) = S
    
15.                ii = ii + 1
    
16.             End If
    
17.             Stile = ""                                                          '清除記錄欗位的標頭
    
18.             S = ""                                                              '清除記錄
    
19.         ElseIf InStr(d(i), ":") Then
    
20.             Stile = Stile & IIf(Stile <> "", "##", "") & Split(d(i), ":")(0)    '記錄欗位的標頭
    
21.             S = S & IIf(S <> "", "##", "") & Trim(Replace(d(i), Mid(d(i), 1, InStr(d(i), ":")), ""))
    
22.         ElseIf InStr(d(i), ":") = 0 Then
    
23.             S = S & IIf(InStr(d(i - 1), ":"), "", Chr(10)) & Trim(d(i))
    
24.         End If
    
25.     Next
    
26.     ReDim Preserve A(0 To ii)
    
27.     A(ii) = S                                                                    '最後一筆資料
    
28.     If Len(Stile) > Len(Tile) Then Tile = Stile                                  '確定欗位標頭
    
29.     With ActiveSheet
    
30.         .Cells.Clear
    
31.         .[A1].Resize(1, UBound(Split(Tile, "##")) + 1) = Split(Tile, "##")       '匯入欗位標頭
    
32.         For Each i In A
    
33.             .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(1, UBound(Split(i, "##")) + 1) = Split(i, "##")
    
34.                                                                                   '匯入紀錄資料
    
35.         Next
    
36.         .Columns.EntireColumn.AutoFit                                             '調整欄寬
    
37.     End With
    
38. End Sub

複製代碼

kulisung

回復 15# GBKEE

感謝GBKEE回覆
測試過可以滿足需求的格式
感謝幫忙～

xiaoyuandlg

I am quite interested in this topic though I am new to the using of VBA, this question also remind me of the qrcode excel