【VBA技巧】- 單元格內容拆分並重組到一對多

最近幾天幫助幾位小朋友解決Excel問題，遇到最經典的問題就是需要拆分一對一的內容到一對多，數據截圖如下：

通過上圖可以看到數據有2列，【訂單編號】和【物流單號】，其中【訂單編號】一列中包含多個以逗號分隔的訂單，也就是說該列中每一個單元格包含至少一個訂單，也可能包含多個訂單，要求是變為如下所示的一對多關係：

可以很清楚的看出，A2單元格的兩個訂單分別拆分到D1和D2單元格，物流編號都是一樣的。究竟需要如何去做才能得到上圖效果呢？

剛剛接觸到該問題，我在想能否不適用VBA來達到，通過一段時間的思考，是可以通過數據分列+數據透視表來完成。但由於訂單編號列不知道數據具體長度，但每一個訂單都超過15位，所以直接分列會出現變為科學計數法，可以在分列的時候設置為文本即可。

由於該方法比編寫VBA代碼更加繁瑣，在此處就不介紹了。

*****************************************************************n過程名稱：sut12nAnn過程參數：無nn過程作用：實現數據一對多nnAuthor：StevennDate：2017-08-06nQQ群：615356012，審核人：Stevenn微信公眾號：SaveUTimennSub sut12nA()n Dim i, iCount As Integern Dim Arr As Variantn 定義一個二維數組，用來存放數據n Dim sutArray(0 To 5000, 0 To 1)n Worksheets("案例一").Selectn Range("D2:E5000").ClearContentsn Range("A2").Selectn 用來保存數據總條數n iCount = 0n 循環處理訂單編號n Do While ActiveCell.Value <> ""n Arr = Split(ActiveCell.Value, ",")n For i = 0 To UBound(Arr)n MsgBox arr(i)n sutArray(iCount + i, 0) = "" & Arr(i)n sutArray(iCount + i, 1) = "" & ActiveCell.Offset(0, 1).Valuen Nextn iCount = iCount + UBound(Arr) + 1n 下移單元格n ActiveCell.Offset(1, 0).Selectn Loopn Range("D2").Resize(UBound(sutArray(), 1), UBound(sutArray(), 2) + 1) = sutArrayn 生成的二維數組數據保存到單元格n Range("D2:E2").Resize(iCount) = sutArrayn Range("D2").SelectnEnd Subn*****************************************************************n

為了更加方便調用宏，特地通過插入形狀並綁定宏，可以通過單擊圖形即可執行宏代碼。

如果【調試代碼】按鈕不會設置，請查看文章【VBA技巧】- 99.9%的人所不知道的Excel隱藏技能。

為了更加直觀的演示，特地使用LICEcap錄製如下動態圖：

如果對代碼還不夠理解，可以逐步調試，就可以理解代碼的含義了。為了讓大家對該類問題更加了解，我還為大家準備了案例二（來自EH論壇），案例二的要求如下：

這兩個案例非常類似，都是需要把數據由一對一變為一對多，具體實現代碼如下：

*****************************************************************n過程名稱：sut12nBnn過程參數：無nn過程作用：實現數據一對多nnAuthor：StevennDate：2017-08-06nQQ群：615356012，審核人：Stevenn微信公眾號：SaveUTimennSub sut12nB()n Dim sutArr, sutBrr, i&, j%, N&, Tn Worksheets("案例二").Selectn [D2:E60000].ClearContentsn sutArr = Range([B2], [A65536].End(xlUp))n 重新定義sutBrr為二維數組n ReDim sutBrr(60000, 1)n For i = 1 To UBound(sutArr)n T = Split(sutArr(i, 1), "/")n For j = 0 To UBound(T)n sutBrr(N, 0) = Left(T(0), Len(T(0)) - Len(T(j))) & T(j)n sutBrr(N, 1) = sutArr(i, 2)n N = N + 1n Next jn Next in [D2:E2].Resize(N) = sutBrrn Erase sutArr, sutBrrnEnd Subn*****************************************************************n

今天為大家介紹的兩個案例都是對數據進行拆分，如果需要合併相同屬性區域請移步我的另一篇文章【Excel VBA】- 合併相同屬性區域。還有一位小夥伴諮詢我也一併解答了，具體問題和解答方法請見下圖：

上一期為大家介紹了強大的動態看板，不知道大家都會製作了嗎？如果學習過程中遇到任何問題，歡迎加群（QQ群：615356012）交流，想要素材的小夥伴可以在公眾號回復「20170808」得到哦~後期文章附帶的素材，大家都可以通過在公眾號回復該文檔發送的日期得到，歡迎下載學習^_^Written by Steven in 20170808^_^

微信公眾號：SaveUTime

SUT學習交流群：615356012，入群審核人：Steven

關注公眾號，提高效率，節約您的時間！