स्प्लिट अल्पविराम नई पंक्तियाँ

Question

मैं वर्तमान में एक पत्रक में इस डेटा के लिए प्रविष्टियों अलग

Col A Col B 
1  angry birds, gaming 
2  nirvana,rock,band 

मुझे क्या करना, दूसरे कॉलम में अल्पविराम से अलग प्रविष्टियों विभाजित है और नीचे की तरह नई पंक्तियों में सम्मिलित किया जाता है चाहता हूँ क्या:

Col A Col B 
1 angry birds 
1 gaming 
2 nirvana 
2 rock 
2 band 

मुझे यकीन है कि यह वीबीए के साथ किया जा सकता है लेकिन इसे स्वयं नहीं समझ सका।

Answer 1

आप सेल छोरों के बजाय संस्करण सरणियों का उपयोग कर बेहतर होगा में परिणाम होता है - वे बहुत जल्दी कोड बुद्धिमान एक बार डेटा सेट सार्थक कर रहे हैं। यहां तक ​​कि कोड भी लंबा है :)

नीचे यह नमूना स्तंभ सी और डी पर डंप करता है ताकि आप मूल डेटा देख सकें। बदलें [c1].Resize(lngCnt, 2).Value2 = Application.Transpose(Y)[a1].Resize(lngCnt, 2).Value2 = Application.Transpose(Y) करने के लिए अपने मूल डेटा

Sub SliceNDice() 
Dim objRegex As Object 
Dim X 
Dim Y 
Dim lngRow As Long 
Dim lngCnt As Long 
Dim tempArr() As String 
Dim strArr 
Set objRegex = CreateObject("vbscript.regexp") 
objRegex.Pattern = "^\s+(.+?)$" 
'Define the range to be analysed 
X = Range([a1], Cells(Rows.Count, "b").End(xlUp)).Value2 
Redim Y(1 To 2, 1 To 1000) 
For lngRow = 1 To UBound(X, 1) 
    'Split each string by "," 
    tempArr = Split(X(lngRow, 2), ",") 
    For Each strArr In tempArr 
     lngCnt = lngCnt + 1 
     'Add another 1000 records to resorted array every 1000 records 
     If lngCnt Mod 1000 = 0 Then Redim Preserve Y(1 To 2, 1 To lngCnt + 1000) 
     Y(1, lngCnt) = X(lngRow, 1) 
     Y(2, lngCnt) = objRegex.Replace(strArr, "$1") 
    Next 
Next lngRow 
'Dump the re-ordered range to columns C:D 
[c1].Resize(lngCnt, 2).Value2 = Application.Transpose(Y) 
End Sub 

Answer 2

स्तंभ एक में अपने डेटा को ले जाता है और स्तंभ सी

Sub SplitAll() 
    Dim src As Range 
    Dim result As Variant 
    For Each src In Range("A:A").SpecialCells(xlCellTypeConstants) 
     result = Split(src, ",") 
     'last cell in column C 
     With Cells(Rows.Count, 3).End(xlUp) 
      Range(.Offset(1, 0), .Offset(1 + UBound(result, 1), 0)) = Application.WorksheetFunction.Transpose(result) 
     End With 
    Next src 
End Sub