[發問] 字串拆解資料轉置問題

child

請教如何針對E欄MEMO的儲存格字串拆解並將相同列資料轉置，E欄MEMO的儲存格字串資料會以空格或;符號分隔字串。
計算空格或;符號字串分隔次數，將A~D欄資料依分隔次數複製H~K欄位，再將分隔的E欄資料轉置成L和M欄資料。
詳細資料與問題說明如附件 Book1.zip (2.38 KB)

下載次數: 17

2015-8-31 22:17

，謝謝大家的幫忙 ^_^

GBKEE

回復 1# child
試試看

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Rng As Range, AR As Variant, i As Integer
   
4.     With Sheets("Sheet1")           '資料所在的工作表
   
5.         Set Rng = .Range("A2:D2")   'A~D欄資料的第一個資料
   
6.         Do While Rng.Cells(1) <> "" 'A欄有資料
   
7.             AR = Replace(Rng.Cells(1, 5), " ", ";") '替換空格為;
   
8.             AR = Split(AR, ";")                     '以";"字串分割的陣列
   
9.             For i = 0 To UBound(AR)                 '依序讀取陣列元素數
   
10.                 'H:M 的表頭已預置好
    
11.                 With Cells(Rows.Count, "H").End(xlUp).Offset(1) 'H欄的第一個空白儲存格
    
12.                     .Resize(1, Rng.Columns.Count) = Rng.Value
    
13.                     '以"*"字串分割的陣列
    
14.                     .Cells(1, Rng.Columns.Count + 1) = Split(AR(i), "*")(0) '陣列的第一個元素值
    
15.                     With .Cells(1, Rng.Columns.Count + 2)
    
16.                         If UBound(AR) > 0 Then                              '陣列最大可使用的陣列索引=-1  -> 空的陣列
    
17.                             .Cells = Split(AR(i), "*")(1)                   '陣列的第二個元素值
    
18.                         Else
    
19.                             .Cells = 1
    
20.                         End If
    
21.                     End With
    
22.                 End With
    
23.             Next
    
24.             Set Rng = Rng.Offset(1)  '下一個A欄資料
    
25.         Loop
    
26.     End With
    
27. End Sub

複製代碼

child

回復 2# GBKEE
謝謝版主的幫忙^_^
測試如果是未分隔的字串N1或N1*6兩字串QTY都會等於1，如果要修改為N1的QTY等於1、N1*6的QTY等於6和避免E欄儲存格有多餘空格(Ex:N1 或A1*1  A2*3)時，
.Cells(1, Rng.Columns.Count + 1) = Split(AR(i), "*")(0) '陣列的第一個元素值會出現異常，請教要如何修改程式碼，謝謝喔!

ikboy

Sub zz()
Dim arr, zr%, zc%, MyMemo, brr() As String
zr = [a1].CurrentRegion.Rows.Count
zc = [a1].CurrentRegion.Columns.Count
n = -1
arr = Range(Cells(2, 1), Cells(zr, zc))
For i = 1 To UBound(arr)
    MyMemo = Split(Application.Substitute(arr(i, 5), " ", ";"), ";")
    For j = 0 To UBound(MyMemo)
        PQ = Split(MyMemo(j), "*")
            n = n + 1: ReDim Preserve brr(5, n)
            For ii = 0 To 3
                brr(ii, n) = arr(i, ii + 1)
            Next
            brr(4, n) = PQ(0)
            If UBound(PQ) = 1 Then
                If PQ(1) > 1 Then
                    brr(5, n) = PQ(1)
                Else
                    brr(5, n) = 1
                End If
            Else
                brr(5, n) = 1
            End If
    Next
Next
[h2].Resize(n + 1, 6) = Application.Transpose(brr)
End Sub

准提部林

Sub TEST()
Dim xR As Range, xH As Range, TT, TR
Set xR = [A1]: Set xH = [H2]
Do
Set xR = xR(2): If xR = "" Then Exit Do
For Each TT In Split(Replace(xR(1, 5), ";", " "), " ")
　　If TT <> "" Then
　　　xH.Resize(1, 4) = xR.Resize(1, 4).Value
　　　xH(1, 5).Resize(1, 2) = Split(TT & "*1", "*")
　　　Set xH = xH(2)
　End If
Next
Loop
End Sub

注意：ａ欄必須是連續資料
　

GBKEE

回復 3# child

請自行修改

1. If UBound(Split(AR(i), "*")) > 0 Then               '陣列最大可使用的陣列索引=-1  -> 空的陣列
   
2.                             .Cells = Split(AR(i), "*")(1)                   '陣列的第二個元素值
   
3.                         Else
   
4.                             .Cells = 1
   
5.                         End If

複製代碼

child

回復 5# 准提部林
測試OK，很謝謝大家的幫忙，也謝謝版主和ikboy的幫忙，我會再試著修改，謝謝喔！