帖子: 38
主題: 20
精華: 0
積分: 83
點名: 0
作業系統: XP
軟體版本: 2003
閱讀權限: 20
性別: 男
來自: TAIWAN
註冊時間: 2010-5-10
最後登錄: 2019-2-15

1^# 跳轉到 » 倒序看帖

字體大小: tT

發表於 2015-8-31 22:18 | 只看該作者

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

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

Book1.zip (2.38 KB) ，謝謝大家的幫忙 ^_^

樓主熱帖

小孩

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2015-9-1 08:59 | 只看該作者

回復 1# child
試試看

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

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

child

中學生 Rank: 2

帖子: 38
主題: 20
精華: 0
積分: 83
點名: 0
作業系統: XP
軟體版本: 2003
閱讀權限: 20
性別: 男
來自: TAIWAN
註冊時間: 2010-5-10
最後登錄: 2019-2-15

3^#

發表於 2015-9-1 10:09 | 只看該作者

回復 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) '陣列的第一個元素值會出現異常，請教要如何修改程式碼，謝謝喔!

小孩

TOP

ikboy

中學生 Rank: 2

帖子: 262
主題: 8
精華: 0
積分: 280
點名: 16
作業系統: xp
軟體版本: Office 2007
閱讀權限: 20
性別: 男
來自: HK
註冊時間: 2015-8-11
最後登錄: 2024-9-14

2016猴年全勤獎章

4^#

發表於 2015-9-1 10:36 | 只看該作者

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

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2825
主題: 10
精華: 0
積分: 2881
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-9-15

5^#

發表於 2015-9-1 10:48 | 只看該作者

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

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

TOP

GBKEE