EXCEL VBA USING SPLIT FUNCTION
Using VBA Split function to Split the concatenated values
into separate rows
Split
function returns a one dimensional array with base 0. Its second argument
represents the delimiter used to split a text and its first argument is the
text to be broken into separate texts.
Let us suppose that some values
are in the concatenated form as shown in the left most column in the below
table1. How can we derive many to one table as shown in the output table2? Splitting
the concatenated values into separate rows help in lookup operation. The code
required to generate the output table is given in the following code
TABLE1
Roll
|
Status
|
Code
|
72323
|
Good
|
ASK-435
|
58221
|
Better
|
DSV-239
|
97741
|
Best
|
BHA-886
|
43651, 38254
|
Good
|
NJA-185
|
30560, 50280, 81068
|
Good
|
AGA-269
|
30522, 87405
|
Good
|
KDV-208
|
63815, 95758
|
Better
|
FHG-327
|
40956, 87242, 62188, 71326
|
Best
|
FGF-602
|
74285, 98732, 46702
|
Good
|
FGF-959
|
75318, 76681, 14579
|
Better
|
RTR-135
|
94490, 43198, 63096
|
Best
|
OIO-891
|
71770
|
Good
|
JHH-880
|
68383
|
Good
|
OPI-222
|
15154, 26989, 63908, 28865, 95430
|
Better
|
YYU-333
|
TABLE2:
Roll
|
Code
|
72323
|
ASK-435
|
58221
|
DSV-239
|
97741
|
BHA-886
|
43651
|
NJA-185
|
38254
|
NJA-185
|
30560
|
AGA-269
|
50280
|
AGA-269
|
81068
|
AGA-269
|
30522
|
KDV-208
|
87405
|
KDV-208
|
63815
|
FHG-327
|
95758
|
FHG-327
|
40956
|
FGF-602
|
87242
|
FGF-602
|
62188
|
FGF-602
|
71326
|
FGF-602
|
74285
|
FGF-959
|
98732
|
FGF-959
|
46702
|
FGF-959
|
75318
|
RTR-135
|
76681
|
RTR-135
|
14579
|
RTR-135
|
94490
|
OIO-891
|
43198
|
OIO-891
|
63096
|
OIO-891
|
71770
|
JHH-880
|
68383
|
OPI-222
|
15154
|
YYU-333
|
26989
|
YYU-333
|
63908
|
YYU-333
|
28865
|
YYU-333
|
95430
|
YYU-333
|
Option Explicit
Sub pConcatSpeakerID()
Dim varData
Dim varResult()
Dim lngFR As Long
Dim lngR As Long
Dim lngK As Long
Dim lngDim As Long
Dim strCon As String
Application.ScreenUpdating = False
On Error GoTo lblError
lngFR =
Range("A1").CurrentRegion.Rows.Count
ReDim varResult(1 To lngFR * 5, 1 To 2)
varData = Range("A1:C" &
lngFR)
For lngR = 1 To lngFR
If UBound(Split(varData(lngR, 1))) = 0
Then
lngK = lngK + 1
varResult(lngK, 1) =
Trim(varData(lngR, 1))
varResult(lngK, 2) = varData(lngR,
3)
Else
For lngDim = 0 To
UBound(Split(varData(lngR, 1)))
lngK = lngK + 1
varResult(lngK, 1) = Split(Trim(varData(lngR,
1)), ",")(lngDim)
varResult(lngK, 2) =
varData(lngR, 3)
Next
End If
Next
Range("E1").CurrentRegion.ClearContents
Range("E1").Resize(lngK, 2) =
varResult
lblError:
If Err.Number <> 0 Then
MsgBox "Error Number:" &
Err.Number & vbCrLf & "Error Description: " & Err.Number
End If
Application.ScreenUpdating =
True
End Sub
No comments:
Post a Comment