there was a similar question answered but in practice it doesn't quite work. I don't know if there is a better way to accomplish my task.
I need to extract the data between "(" and the third "," for example
$$ Data_out(3,47,0,40,0,0,2,8.01) and having the result be 3,47,0 I will add below what I've tried
Dim str As String
Dim openPos As Integer
Dim closePos As Integer
Dim midBit As String
ActiveSheet.Range("A2").Activate
Do While Range("A:A").Cells(i, 1).Value <> ""
On Error Resume Next
openPos = InStr(str, "(")
On Error Resume Next
closePos = InStr(str, ",0,")
On Error Resume Next
midBit = Mid(str, openPos + 1, closePos - openPos - 1)
extract_value = midBit
ActiveCell.Value = midBit
i = i + 1
Loop
Different approach:
Sub Tester()
Dim txt, txt2, arr
txt = "$$ Data_out(3,47,0,40,0,0,2,8.01)" 'input...
txt2 = Split(txt, "(")(1) 'everything after first "("
arr = Split(txt2, ",") 'split on comma
ReDim Preserve arr(0 To 2) 'first 3 elements only
Debug.Print Join(arr, ",") 'join to string
End Sub
Read some VBA tutorials to master the basics.
Here's an alternative which use the worksheet function Substitute which has an instance parameter so you can pick out the third comma.
Sub x()
Dim str As String
Dim openPos As Long, closePos As Long
Dim midBit As String
Dim r As Long
For r = 2 To Range("A" & Rows.Count).End(xlUp).Row
openPos = InStr(Cells(r, 1), "(")
str = WorksheetFunction.Substitute(Cells(r, 1), ",", "#", 3) '# or any character not likely to appear in your data
closePos = InStr(str, "#")
If openPos > 0 And Len(str) > 0 Then
midBit = Mid(str, openPos + 1, closePos - openPos - 1)
Cells(r, 1).Value = midBit
End If
Next r
End Sub
Related
I had a module that applied code to clean cells of unicode and replace with a standard letter from a dictionary range, I am trying to now do that by using a 2D array (for the first time) and then reprint the new corrected array back in the original cells. I am getting the type subscript out of range at Redim line, there maybe other errors further down the code I haven't got to yet (the unicode correction code works as used previously). Thanks for your help
Sub Test2DArray()
Worksheets("Sheet1").Activate
Dim arr As Variant, xstr
arr = ActiveSheet.UsedRange
Dim unicleanRWS As Variant, unicleanCLS
For unicleanRWS = LBound(arr, 1) To UBound(arr, 1)
For unicleanCLS = 1 To ActiveSheet.UsedRange.Rows.Count
'Originally the above line was Lbound(arr,2) to ubound(arr,2)
'but I altered as I read I could not preserve both dimensions
ReDim Preserve arr(1 To UBound(arr, 1))
xstr = arr(unicleanRWS, unicleanCLS)
keepchrs = Left(xstr, 0)
For I = 1 To Len(xstr)
If (Mid(xstr, I, 2)) = "\u" Then
Readcode = (Mid(xstr, I, 6))
CorrectUnicode = Replace(Readcode, "\u", "U+")
NormalLetter = Mid(Application.WorksheetFunction.VLookup(CorrectUnicode, _
Worksheets("Unicode").Range("A1:E1000"), 5, False), 2, 1)
xstr = keepchrs & Replace(xstr, (Mid(xstr, I, 6)), LCase(NormalLetter))
xstr = UCase(Left(xstr, 1)) & Mid(xstr, 2)
End If
Next I
arr(unicleanRWS, unicleanCLS) = xstr
Next unicleanCLS
Next unicleanRWS
FirstCell = arr(0, 0).Address
FirstCell.Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub
Clean Values in Range
Option Explicit
Sub Test2DArray()
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim ws As Worksheet
Set ws = wb.Worksheets("Sheet1")
Dim rng As Range
Set rng = ws.UsedRange
Dim arr As Variant
arr = rng.Value
Dim xstr As Variant
Dim i As Long
Dim j As Long
Dim n As Long
Dim keepChrs As String
Dim ReadCode As String
Dim CorrectUnicode As String
Dim NormalLetter As String
For i = 1 To UBound(arr, 1)
For j = 1 To UBound(arr, 2)
xstr = arr(i, j)
keepChrs = Left(xstr, 0)
' This works well, you say.
For n = 1 To Len(xstr)
If (Mid(xstr, n, 2)) = "\u" Then
ReadCode = (Mid(xstr, n, 6))
CorrectUnicode = Replace(ReadCode, "\u", "U+")
NormalLetter = Mid(Application.WorksheetFunction.VLookup(CorrectUnicode, Worksheets("Unicode").Range("A1:E1000"), 5, False), 2, 1)
xstr = keepChrs & Replace(xstr, (Mid(xstr, n, 6)), LCase(NormalLetter))
xstr = UCase(Left(xstr, 1)) & Mid(xstr, 2)
End If
Next n
arr(i, j) = xstr
Next j
Next i
rng.Value = arr
End Sub
Getting your data from a Range into a memory-based array is more straightforward than you're thinking. In your situation, I believe
Dim arr As Variant
arr = ActiveSheet.UsedRange.Value
is all that's required. There is no need for a Redim at all. Alternatively, consider that UsedRange can sometimes give different results. So this example is more of a guarantee to get exactly what you want:
Dim arr As Variant
Dim lastRow As Long
Dim lastCol As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Dim dataRange As Range
Set dataRange = .Range("A1").Resize(lastRow, lastCol)
arr = dataRange.Value
End With
Now, everytime you need to determine the size of the array, you should use the UBound and LBound functions.
VBasic2008's answer worked perfectly for a small set of data but because I had a large amount of data I ended up adding some extra code to break my used range into sections so I have noted the final code below in case anyone else has a large dataset. This took 210 seconds to cleanup 240m cells.
I added a timer as well, and a timed message to avoid a "Not responding" occurence I sometimes get with large data, both are obviously optional but I've included everything in case it is helpful:
Private Function MsgTimed(Message As String, Optional Seconds As Integer = 5, _
Optional Title As String = "", Optional Options As Integer = 0)
' Displays a message box for a predetermined duration then auto closes it.
' Uses the same syntax as the built-in Popup function referenced on the page below...
' http://msdn.microsoft.com/en-us/library/x83z1d9f%28v=vs.84%29.aspx
CreateObject("WScript.Shell").Run "mshta.exe vbscript:close(CreateObject(""WScript.Shell"")" _
& ".Popup(""" & Message & """," & Seconds & ",""" & Title & """," & Options & "))"
End Function
---------------
Sub TestArray()
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim ws As Worksheet
Set ws = wb.Worksheets("Sheet1")
' Look up the usedrange and then break into 10 sections due to size
Dim rng As Range, rng2, srng
Set rng = ws.UsedRange
Dim SectionsRng As Integer
Dim SectionStart As Long, SectionEnd
Dim MaxCol As String
Dim arr As Variant
Dim xstr As Variant
Dim i As Long
Dim j As Long
Dim n As Long
Dim keepChrs As String
Dim ReadCode As String
Dim CorrectUnicode As String
Dim NormalLetter As String
' Create 50 sections of UsedRange to avoid Out of Memory error
SectionStart = rng.Cells.Row
SectionEnd = Round(rng.rows.Count / 50)
MaxCol = Split(Cells(1, rng.Columns.Count).Address, "$")(1)
For SectionsRng = 1 To 50
If SectionsRng > 1 Then SectionStart = 1 + SectionEnd
If SectionsRng > 1 Then SectionEnd = Round(SectionEnd / (SectionsRng - 1) * SectionsRng)
srng = ("$A$" & SectionStart & ":$" & MaxCol & "$" & SectionEnd)
Set rng2 = ws.Range(srng)
Debug.Print rng2.Address
' Create array and process data
arr = rng2.Value
For i = 1 To UBound(arr, 1)
For j = 1 To UBound(arr, 2)
xstr = arr(i, j)
keepChrs = Left(xstr, 0)
For n = 1 To Len(xstr)
If (Mid(xstr, n, 2)) = "\u" Then
ReadCode = (Mid(xstr, n, 6))
CorrectUnicode = Replace(ReadCode, "\u", "U+")
NormalLetter = Mid(Application.WorksheetFunction.VLookup(CorrectUnicode, Worksheets("Unicode").Range("A1:E1000"), 5, False), 2, 1)
xstr = keepChrs & Replace(xstr, (Mid(xstr, n, 6)), LCase(NormalLetter))
xstr = UCase(Left(xstr, 1)) & Mid(xstr, 2)
End If
Next n
arr(i, j) = xstr
Next j
Next i
rng2.Value = arr
' MessageBox seems to stop Not responding occuring
SecondsElapsed = Round(Timer - StartTime, 2)
MsgTimed "Time " & SecondsElapsed & " Reached Row: " & SectionEnd, 3, "Alert", vbInformation
Next SectionsRng
'Print Timer in Immediate Window
Debug.Print SecondsElapsed
End Sub
I have a generated list of part numbers (A2:A100), and their quantities (B2:B100), for a particular order number (C2:C100). I am writing a sub which will filter the list of part numbers for each unique part number and then create a new list with the total quantity of each part and every order where it will be used.
I have a sub that successfully creates a list of unique part numbers (F8:F100), then another sub auto-filters the main list (A2:A100) of part numbers for each unique part number and creates a range for the order numbers (C2:C100) for that particular part. I have tried to concatenate the range of order numbers, but my function is failing.
Sub WOSorter()
Dim rng As Range
Dim WOrng As Range
Dim i As Long
Dim Limit As Long
Dim seperator As String
seperator = ", "
Limit = Worksheets("Selector").Range("F8:F100").Cells.SpecialCells(xlCellTypeConstants).Count - 1
For i = 0 To Limit
Set rng = Worksheets("Selector").Cells(8 + i, 6)
With Worksheets("Selector").Range("A1")
.AutoFilter Field:=1, Criteria1:=rng
Set WOrng = Worksheets("Selector").Range("C2:C100").Cells.SpecialCells(xlCellTypeVisible)
Worksheets("Selector").Cells(8 + i, 9).Value = ConcatenateRange(WOrng, seperator)
End With
Next
If Worksheets("Selector").AutoFilterMode Then Worksheets("Selector").AutoFilter.ShowAllData
End Sub
-----------------------------------------------------------------------------
Function ConcatenateRange(ByVal WOrng As Range, Optional ByVal seperator As String) As String
Dim newString As String
Dim cellArray As Variant
Dim i As Long, j As Long
cellArray = WOrng.Value
For i = 1 To UBound(cellArray, 1)
For j = 1 To UBound(cellArray, 2)
If Len(cellArray(i, j)) <> 0 Then
newString = newString & (seperator & cellArray(i, j))
End If
Next
Next
If Len(newString) <> 0 Then
newString = Right$(newString, (Len(newString) - Len(seperator)))
End If
ConcatenateRange = newString
End Function
I am currently getting a type mismatch error on the line:
For i = 1 To UBound(cellArray, 1)
If the original list is in colA, B, C with unique part numbers in colF:
colA colB colC colF
123-4 1 01111 123-4
456-7 2 02222 456-7
123-4 1 03333 789-0
789-0 1 04444
456-7 3 05555
Then the result should be:
colA colB colC colF colI
123-4 1 01111 123-4 01111, 03333
456-7 2 02222 456-7 02222, 05555
123-4 1 03333 789-0 04444
789-0 1 04444
456-7 3 05555
Using the function on the link change your code to:
Sub WOSorter()
Dim seperator As String
seperator = ", "
With Worksheets("Selector")
Dim lstrow As Long
lstrow = .Cells(.Rows.Count, "F").End(xlUp).Row
Dim i As Long
For i = 2 To lstrow
.Range("I" & i).Value = TEXTJOINIFS(.Range("C:C"), seperator, .Range("A:A"), .Range("F" & i).Value)
Next i
End With
End Sub
This does not rely on filter which will not allow the bulk load of arrays.
Here is the textjoinifs function:
Function TEXTJOINIFS(rng As Range, delim As String, ParamArray arr() As Variant) As String
Dim rngarr As Variant
rngarr = Intersect(rng, rng.Parent.UsedRange).Value
Dim condArr() As Boolean
ReDim condArr(1 To Intersect(rng, rng.Parent.UsedRange).Rows.Count) As Boolean
TEXTJOINIFS = ""
Dim i As Long
For i = LBound(arr) To UBound(arr) Step 2
Dim colArr() As Variant
colArr = Intersect(arr(i), arr(i).Parent.UsedRange).Value
Dim j As Long
For j = LBound(colArr, 1) To UBound(colArr, 1)
If Not condArr(j) Then
Dim charind As Long
charind = Application.Max(InStr(arr(i + 1), ">"), InStr(arr(i + 1), "<"), InStr(arr(i + 1), "="))
Dim opprnd As String
If charind = 0 Then
opprnd = "="
Else
opprnd = Left(arr(i + 1), charind)
End If
Dim t As String
t = """" & colArr(j, 1) & """" & opprnd & """" & Mid(arr(i + 1), charind + 1) & """"
If Not Application.Evaluate(t) Then condArr(j) = True
End If
Next j
Next i
For i = LBound(rngarr, 1) To UBound(rngarr, 1)
If Not condArr(i) Then
TEXTJOINIFS = TEXTJOINIFS & rngarr(i, 1) & delim
End If
Next i
If TEXTJOINIFS <> "" Then
TEXTJOINIFS = Left(TEXTJOINIFS, Len(TEXTJOINIFS) - Len(delim))
End If
End Function
Here is the ouput:
Given a list of strings, I want to divide the strings into different columns. The strings does not always comes in the same format, so I cannot use the same approach each time. I am trying to put the LC-XXXXXX in column B, then delete the "s" and put the text after the "s" and between the "^" or the "." (whatever the string contains) into column C
I am running a "for loop" for each string in which is saved as an array and looks something like this:
I have use the split, trim and mid commands but with no success.
With Sheets("TELECOM")
.Range("A14", "I305").ClearContents
For Each objFile In objFolder.Files
On Error Resume Next
If InStr(objFile.Name, "LC-9") > 0 And InStr(objFile.Type, "DWG File") > 0 Then
drwn = objFile.Name
.Cells(r, 2) = Left(drwn, InStr(1, drwn, "s") - 1) 'Get the drawing number and placing it here
values = Array(drwn)
Set re = CreateObject("vbscript.regexp")
pattern = "(s\d+)"
For i = LBound(values) To UBound(values)
.Cells(r, 3) = Replace$(drwn, "s", vbNullString)
Next
r = r + 1
End With
Public Function GetId(ByVal re As Object, ByVal s As String, ByVal pattern As String) As String
With re
.Global = True
.MultiLine = True
.IgnoreCase = False '? True if case insensitive
.pattern = pattern
If .test(s) Then
GetId = .Execute(s)(0).SubMatches(0)
End If
End With
End Function
I would like to take the list of stings and put the LC-XXXXX in column B and the sheet number (numbers between the "s" and the "^" or sometimes the ".dwg" or ".pdf") into a column C
NEW EDIT 04/06/2019
New Edit 04/07/2019
Main Code
Sub GetIssued()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim openPos As Integer
Dim closePos As Integer
Dim sh As Object
Dim drwn, SheetNum
Set objFSO = CreateObject("scripting.FileSystemObject")
r = 14
fle = ThisWorkbook.Sheets("Header Info").Range("D11") &
"\Design\Substation\CADD\Working\COMM\"
Set objFolder = objFSO.GetFolder(fle)
Set x1Book = ActiveWorkbook 'Using this Activeworkbook
Set sh = x1Book.Sheets("TELECOM") 'Using this particular sheet
With Sheets("TELECOM")
.Range("A14", "I305").ClearContents
For Each objFile In objFolder.Files
On Error Resume Next
If InStr(objFile.Name, "LC-9") > 0 And InStr(objFile.Type, "DWG
File") > 0 Then 'PEDs, Single Line, Cable and Wiring, Jumper and
Interconnection
.Cells(r, 9) = objFile.Name 'Testing Purposes
drwn = Array(.Cells(r, 9).Value)
.Cells(r, 2) = Left(drwn, InStr(1, drwn, "s") - 1) 'Get the
drawing number and placing it here
'-----------------------------------------------------------
'Trying to Insert InstrMacro here
'------------------------------------------------------------
r = r + 1
ElseIf InStr(objFile.Name, "MC-9") > 0 And InStr(objFile.Type, "DWG File") > 0 Then 'Cable List
.Cells(r, 9) = objFile.Name 'Testing Purposes
drwn = .Cells(r, 9).Value
.Cells(r, 2) = Left(drwn, InStr(1, drwn, "s") - 1) 'Get the drawing number and placing it here
'-----------------------------------------------------------
'Trying to Insert InstrMacro here
'------------------------------------------------------------
r = r + 1
ElseIf InStr(objFile.Name, "BMC-") > 0 And InStr(objFile.Type, "Adobe Acrobat Document") > 0 Then 'Bill of Materials
.Cells(r, 9) = objFile.Name 'Testing Purposes
drwn = .Cells(r, 9).Value
.Cells(r, 2) = Left(drwn, InStr(1, drwn, "s") - 1) 'Get the drawing number and placing it here
'-----------------------------------------------------------
'Trying to Insert InstrMacro here
'------------------------------------------------------------
r = r + 1
ElseIf InStr(objFile.Name, "CSR") > 0 And InStr(objFile.Type, "DWG") > 0 Then 'Single Line Diagram
.Cells(r, 9) = objFile.Name 'Testing Purposes
drwn = .Cells(r, 9).Value
.Cells(r, 2) = Left(drwn, InStr(1, drwn, "s") - 1) 'Get the drawing number and placing it here
'---------------------------------------------------------
'Trying to Insert InstrMacro here
'------------------------------------------------------------
r = r + 1
End If
Next
End With
Range("A13:F305").HorizontalAlignment = xlCenter
Range("A1").Select
End Sub
The marco that I have working can be seen here:
Sub InstrMacro()
Dim openPos As Integer
Dim closePos As Integer
Dim drwn, SheetNum
drwn = Range("E9") ' String to search in the sheet aka: the hot seat
'Performing a test to see if this is a new drawing or not
SheetNum = InStr(drwn, "^")
openPos = InStr(drwn, "s") 'True reguardless of the condition of the drawing
If SheetNum = 0 Then 'Assuming it is a new drawing
closePos = InStr(drwn, ".")
SheetNum = Mid(drwn, openPos + 1, closePos - openPos - 1)
Else
If SheetNum > 0 Then 'Assuming is NOT a new drawing
closePos = InStr(drwn, "^")
SheetNum = Mid(drwn, openPos + 1, closePos - openPos - 1)
End If
End If
Range("G20").Value = SheetNum
End Sub
A picture for this macro can be seen here.
I have tried making a separate macro the runs and can get the sheet number, but it seems that excel is just skipping this step and running through the rest of the program
I would like to put the drawing number in column B and the sheet number in sheet number in column c.
A solution with no loops nor regex
Sub FindIt()
Dim strng As String, iPos As Long
strng= "1sa2sb3s4sd5se"
iPos = InStr(strng, "s")
If iPos > 0 And iPos < Len(strng) Then
If InStr("1234567890", Mid(strng, iPos + 1, 1)) > 0 Then
MsgBox "Found s" & Mid(strng, iPos + 1,1) & " at position " & iPos
End If
End If
End Sub
Which can be easily twicked to limit the number of numeric digits following the “s” character
If it is s followed by a number/numbers, and this pattern only occurs once, you could use regex.
Option Explicit
Public Sub test()
Dim re As Object, pattern As String, values(), i As Long
values = Array("LC-94773s2^003735377.pdf", "LC-94773s2", "LC-93521s1-A^005241446")
Set re = CreateObject("vbscript.regexp")
pattern = "(s\d+)"
For i = LBound(values) To UBound(values)
Debug.Print Replace$(GetId(re, values(i), pattern), "s",vbNullString)
Next
End Sub
Public Function GetId(ByVal re As Object, ByVal s As String, ByVal pattern As String) As String
With re
.Global = True
.MultiLine = True
.IgnoreCase = False '? True if case insensitive
.pattern = pattern
If .test(s) Then
GetId = .Execute(s)(0).SubMatches(0)
Else
GetId = "No match"
End If
End With
End Function
You can vary this pattern, for example, if want start to be LC-9
Public Sub test()
Dim re As Object, pattern As String, values(), i As Long
values = Array("LC-94773s2^003735377.pdf", "LC-94773s2", "LC-93521s1-A^005241446")
Set re = CreateObject("vbscript.regexp")
pattern = "LC-9(.*)(s\d+)"
For i = LBound(values) To UBound(values)
Debug.Print Replace$(GetId(re, values(i), pattern), "s",vbNullString)
Next
End Sub
To see if a string contains a lower case s followed by a numeral:
Sub sTest()
Dim s As String, i As Long
s = "jkuirelkjs6kbco82yhgjbc"
For i = 0 To 9
If InStr(s, "s" & CStr(i)) > 0 Then
MsgBox "I found s" & i & " at position " & InStr(s, "s" & CStr(i))
Exit Sub
End If
Next i
MsgBox "pattern not found"
End Sub
You could try:
Option Explicit
Sub test()
Dim arr As Variant
Dim i As Long
arr = Array("LC-94773s2^003735377.pdf", "LC-94773s2", "Mar", "LC-93521s1-A^005241446")
For i = LBound(arr) To UBound(arr)
If InStr(1, arr(i), "s") Then
Debug.Print Mid(arr(i), InStr(1, arr(i), "s"), 2)
End If
Next i
End Sub
I have dataset in the format "Ping 172.123.123.123=[150ms]". How can i get the sum of what is within "[" and "]"?. I have many rows and columns and was hoping to get the SUM or AVERAGE of all ping
Example in the screen shot
Assuming that each cell ends with ]
Public Function SumPings(CellsToSum As Range)
Dim runtot As Double
Dim r As Range
Dim x As Integer
Dim y As Integer
Dim s As String
For Each r In CellsToSum
x = InStr(r.Text, "[")
If x > 0 Then
s = Mid(r.Text, x + 1, Len(r.Text) - x - 1)
runtot = runtot + Val(s)
End If
Next r
SumPings = runtot
End Function
This will sum each column and add the total to the last row of each column:
Sub foo()
Dim openPos As Integer
Dim closePos As Integer
Dim midBit As String
Dim Str As String
Dim Extract_value As Integer
LastRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
LastCol = Sheet1.Cells(1, Sheet1.Columns.Count).End(xlToLeft).Column
x = 1
For x = 1 To LastCol
For i = 1 To LastRow
Str = Sheet1.Cells(i, x).Value
On Error Resume Next
openPos = InStr(Str, "[")
On Error Resume Next
closePos = InStr(Str, "m")
On Error Resume Next
midBit = Mid(Str, openPos + 1, closePos - openPos - 1)
If openPos <> 0 And Len(midBit) > 0 Then
Extract_value = Extract_value + midBit
End If
Sheet1.Cells(LastRow + 1, x).Value = Extract_value
Next i
Next x
End Sub
I am trying parse a number string and create rows accordingly. On the left of the Example Data picture is an example of the input data with the right being my desired output. I am wanting to insert a unique row of data for each digit within the brackets for each number combination.
Here is an example of the code I used to try to solve the problem.
Option Explicit
Sub example()
Dim num As Variant
Dim x As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim m As Integer
Dim test As Variant
Dim test2 As Variant
Dim count As Integer
m = 0
For i = 1 To 3
num = Range("C" & 5 + i + m).Value
For j = 1 To Len(num)
test = Mid(num, j)
If Left(Mid(num, j), 1) = "[" Then
For k = 1 To Len(num) - (j + 1)
m = m + 1
Range("C" & 5 + m + i - 1).EntireRow.Insert
test2 = Left(Mid(num, j + k), 1)
Range("C" & 5 + m + i - 1).Value = Left(num, j - 1) + test2
Next k
End If
Next j
Next i
End Sub
Please consider using the following script:
Sub splitcombinations()
Dim rngCell As Range
Set rngCell = ThisWorkbook.Sheets(1).Range("A2")
Dim strCombinationDigits As String, strBaseDigits As String
Dim intCombinationDigitsLen As Integer
Dim x As Integer
Do While rngCell.Value2 <> ""
If InStr(rngCell.Value2, "[") > 0 Then
strCombinationDigits = Mid(rngCell.Value2, InStr(rngCell.Value2, "[") + 1, InStr(rngCell.Value2, "]") - InStr(rngCell.Value2, "[") - 1)
intCombinationDigitsLen = Len(strCombinationDigits)
strBaseDigits = Left(rngCell.Value2, InStr(rngCell.Value2, "[") - 1)
ActiveSheet.Range(rngCell.Offset(1, 0), rngCell.Offset(intCombinationDigitsLen - 1, 0)).EntireRow.Insert
For x = 1 To intCombinationDigitsLen
rngCell.Offset(x - 1, 0).Value2 = strBaseDigits & Mid(strCombinationDigits, x, 1)
rngCell.Offset(x - 1, 1).Value2 = rngCell.Offset(0, 1).Value2
rngCell.Offset(x - 1, 2).Value2 = rngCell.Offset(0, 2).Value2
Next
End If
Set rngCell = rngCell.Offset(intCombinationDigitsLen , 0)
Loop
End Sub