Related
as a beginner in VBA programming I have a hard time figuring out what the problem is. The code works perfectly when the values increase in order, but when there are values in the array that are not similar then I get an error.
When the problematic values are loaded, an error occurs Run time error 9, subscript out of range and this line is highlighted in the code sequenceArr(counter) = arr(i + 1) The main task of the code is to make short notations of long strings of numbers and to make a separation between different strings.
For example: i have box ID numbers: M0054515, M0054516, M0054517, M0054620, M0054621, M0054622, M0054751, M0054752, M0054753
When i run macro i get output result like this:
M0054515-517 // M0054620-622 // M0054751-753.
But when i have some random numbers in middile of ID number series i get an error... M0046552, M0047396, M0047399, M0047802, M0047803 instead of separated values i get run time error message.
At this link is an example version of my book, if anyone wants to help solve the problem.
For this job I use this code written a long time ago by another member of this forum
Sub Generate()
Dim ws As Worksheet
Dim arr() As String, result As String, letter As String, cellValue As String, tempLastElement As String
Dim lastColumn As Long, counter As Long
Dim firstColumn As Integer, targetRow As Integer, i As Integer
Set ws = Worksheets("KreirajRadniNalog")
firstColumn = 1
targetRow = 1
lastColumn = ws.Range(ws.Cells(targetRow, firstColumn), ws.Cells(targetRow, Columns.Count).End(xlToLeft).Columns).Count
ReDim arr(1 To lastColumn - firstColumn + 1)
letter = Left(ws.Cells(targetRow, firstColumn).Value, 1)
For i = 1 To UBound(arr)
cellValue = ws.Cells(targetRow, i).Value
arr(i) = Right(cellValue, Len(cellValue) - 1)
Next i
ReDim sequenceArr(1 To UBound(arr))
sequenceArr(1) = arr(1)
counter = 2
For i = 1 To UBound(arr) - 1
If CLng(arr(i)) + 1 = CLng(arr(i + 1)) Then
tempLastElement = arr(i + 1)
sequenceArr(counter) = tempLastElement
Else
counter = counter + 1
sequenceArr(counter) = arr(i + 1) '<<<this line here is highlighted
counter = counter + 1
End If
Next
ReDim Preserve sequenceArr(1 To counter)
result = ""
counter = 1
For i = 1 To UBound(sequenceArr) - 1
If counter > UBound(sequenceArr) Then Exit For
If result = "" Then
result = letter & sequenceArr(counter) & "-" & Right(sequenceArr(counter + 1), 3)
counter = counter + 2
Else
result = result & "//" & letter & sequenceArr(counter) & "-" & Right(sequenceArr(counter + 1), 3)
counter = counter + 2
End If
Next
ws.Range("C4").Value = result
End Sub
Please, try the next updated code. Since you did not answer my clarification question, I (only) hope that I could deduce what you want accomplishing...
Sub Generate()
Dim ws As Worksheet
Dim arr, sequenceArr, letter As String, cellValue As String, tempLastElement As String
Dim lastColumn As Long, counter As Long, firstColumn As Long, targetRow As Integer, i As Long, j As Long
Set ws = Worksheets("KreirajRadniNalog")
firstColumn = 1: targetRow = 1
lastColumn = ws.Range(ws.Cells(targetRow, firstColumn), ws.Cells(targetRow, Columns.Count).End(xlToLeft).Columns).Count
ReDim arr(1 To lastColumn - firstColumn + 1)
letter = Left(ws.Cells(targetRow, firstColumn).Value, 1)
For i = 1 To UBound(arr)
cellValue = ws.Cells(targetRow, i).Value
arr(i) = Right(cellValue, Len(cellValue) - 1)
Next i
ReDim sequenceArr(1 To UBound(arr))
counter = 1
For i = 1 To UBound(arr) - 1
If CLng(arr(i)) + 1 = CLng(arr(i + 1)) Then
For j = 0 To UBound(arr)
If i + j + 1 > UBound(arr) Then Exit For
If CLng(arr(i)) + j + 1 = CLng(arr(i + 1 + j)) Then
tempLastElement = arr(i + 1 + j)
Else
Exit For
End If
Next j
sequenceArr(counter) = arr(i) & "-" & Right(tempLastElement, 3)
counter = counter + 1: i = i + j
Else
sequenceArr(counter) = arr(i): counter = counter + 1
End If
Next
ReDim Preserve sequenceArr(1 To counter - 1)
ws.Range("C4").Value = letter & Join(sequenceArr, "//" & letter)
MsgBox "Success!"
End Sub
A more compact version, working with 0 based arrays:
Sub Generate2()
Dim ws As Worksheet
Dim arr, sequenceArr, letter As String, cellValue As String, tempLastElement As String
Dim lastColumn As Long, counter As Long, firstColumn As Long, targetRow As Integer, i As Long, j As Long
Set ws = Worksheets("KreirajRadniNalog")
firstColumn = 1: targetRow = 1
lastColumn = ws.Range(ws.Cells(targetRow, firstColumn), ws.Cells(targetRow, Columns.Count).End(xlToLeft).Columns).Count
letter = Left(ws.Cells(targetRow, firstColumn).Value, 1)
With Application
arr = .Transpose(.Transpose(ws.Range(ws.Cells(targetRow, firstColumn), ws.Cells(targetRow, lastColumn)).Value))
End With
arr(1) = Mid(arr(1), 2)
arr = Split(Join(arr, "|"), "|" & letter)
ReDim sequenceArr(UBound(arr))
counter = 0
For i = 0 To UBound(arr) - 1
If CLng(arr(i)) + 1 = CLng(arr(i + 1)) Then
For j = 0 To UBound(arr)
If i + j + 1 > UBound(arr) Then Exit For
If CLng(arr(i)) + j + 1 = CLng(arr(i + 1 + j)) Then
tempLastElement = arr(i + 1 + j)
Else
Exit For
End If
Next j
sequenceArr(counter) = arr(i) & "-" & Right(tempLastElement, 3)
counter = counter + 1: i = i + j
Else
sequenceArr(counter) = arr(i): counter = counter + 1
End If
Next
ReDim Preserve sequenceArr(1 To counter)
ws.Range("C4").Value = letter & Join(sequenceArr, "//" & letter)
MsgBox "Success!"
End Sub
The problem with your code is here
Else
counter = counter + 1
sequenceArr(counter) = arr(i + 1) '<<<this line here is highlighted
counter = counter + 1
End If
because for every single number the counter is incremented twice and so exceeds the array size. However you don't really need arrays
Sub Generate()
Dim ws As Worksheet, arr
Dim lastColumn As Long, letter As String, tmp As String
Dim result As String, i As Long, m As Long, n As Long
Set ws = Worksheets("KreirajRadniNalog")
Const firstColumn = 1
Const targetRow = 1
lastColumn = ws.Cells(targetRow, Columns.Count).End(xlToLeft).Column
arr = ws.Cells(targetRow, 1).Resize(, lastColumn)
result = arr(1, 1)
m = Mid(arr(1, 1), 2)
For i = 2 To UBound(arr, 2)
n = Mid(arr(1, i), 2)
If n = m + 1 Then
tmp = "-" & Right(Val(Mid(arr(1, i), 2)), 3)
Else
result = result & tmp & "//" & arr(1, i)
tmp = ""
End If
m = n
Next
result = result & tmp
ws.Range("C4").Value = result
End Sub
The code I have takes cells containing the delimiter (; ) from a column, and creates new rows (everything except the column is duplicated) to separate those values.
What I have
I need this for multiple columns in my data, but I don't want the data to overlap (ex: for 3 columns, I want there to be only one value per row in those 3 columns). It would be ideal if I could select multiple columns instead of only one as my code does now.
What I want
Sub splitByCol()
Dim r As Range, i As Long, ar
Set r = Worksheets("Sheet").Range("J2000").End(xlUp)
Do While r.Row > 1
ar = Split(r.Value, "; ")
If UBound(ar) >= 0 Then r.Value = ar(0)
For i = UBound(ar) To 1 Step -1
r.EntireRow.Copy
r.Offset(1).EntireRow.Insert
r.Offset(1).Value = ar(i)
Next
Set r = r.Offset(-1)
Loop
End Sub
Try this code
Sub Test()
Dim a, x, e, i As Long, ii As Long, iii As Long, k As Long
a = Range("A1").CurrentRegion.Value
ReDim b(1 To 1000, 1 To UBound(a, 2))
For i = LBound(a) To UBound(a)
For ii = 2 To 3
x = Split(a(i, ii), "; ")
For Each e In x
k = k + 1
b(k, 1) = k
b(k, 2) = IIf(ii = 2, e, Empty)
b(k, 3) = IIf(ii = 3, e, Empty)
b(k, 4) = a(i, 4)
Next e
Next ii
Next i
Range("A5").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
I'd go this way
Sub SplitByCol()
With Worksheets("Sheet")
With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
Dim firstColValues As Variant
firstColValues = .Value
Dim secondColValues As Variant
secondColValues = .Offset(, 1).Value
Dim thirdColValues As Variant
thirdColValues = .Offset(, 2).Value
.Offset(, -1).Resize(, 4).ClearContents
End With
Dim iRow As Long
For iRow = LBound(firstColValues) To UBound(firstColValues)
Dim currFirstColValues As Variant
currFirstColValues = Split(firstColValues(iRow, 1), "; ")
Dim currSecondColValues As Variant
currSecondColValues = Split(secondColValues(iRow, 1), "; ")
With .Cells(.Rows.Count, "C").End(xlUp).Offset(1, -1)
With .Resize(UBound(currFirstColValues) + 1)
.Value = currFirstColValues
.Offset(, 2).Value = thirdColValues(iRow, 1)
End With
End With
With .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 1)
With .Resize(UBound(currSecondColValues) + 1)
.Value = currSecondColValues
.Offset(, 1).Value = thirdColValues(iRow, 1)
End With
End With
Next
End With
End Sub
Follow the code step by step by pressing F8 while the cursor is in any code line in the VBA IDE and watch what happens in the Excel user interface
EDIT
adding edited code for a more "parametric" handling by means of a helper function
Sub SplitByCol()
With Worksheets("Sheet")
With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
Dim firstColValues As Variant
firstColValues = .Value
Dim secondColValues As Variant
secondColValues = .Offset(, 1).Value
Dim thirdColValues As Variant
thirdColValues = .Offset(, 2).Value
.Offset(, -1).Resize(, 4).ClearContents
End With
Dim iRow As Long
For iRow = LBound(firstColValues) To UBound(firstColValues)
Dim currFirstColValues As Variant
currFirstColValues = Split(firstColValues(iRow, 1), "; ")
Dim currSecondColValues As Variant
currSecondColValues = Split(secondColValues(iRow, 1), "; ")
WriteOne .Cells(.Rows.Count, "C").End(xlUp).Offset(1), _
currFirstColValues, thirdColValues(iRow, 1), _
-1, 2
WriteOne .Cells(.Rows.Count, "B").End(xlUp).Offset(1), _
currSecondColValues, thirdColValues(iRow, 1), _
1, 1
Next
End With
End Sub
Sub WriteOne(refCel As Range, _
currMainColValues As Variant, thirdColValue As Variant, _
mainValuesOffsetFromRefCel As Long, thirdColValuesOffsetFromRefCel As Long)
With refCel.Offset(, mainValuesOffsetFromRefCel)
With .Resize(UBound(currMainColValues) + 1)
.Value = currMainColValues
.Offset(, thirdColValuesOffsetFromRefCel).Value = thirdColValue
End With
End With
End Sub
Please, use the next code. It uses arrays and should be very fast for big ranges to be processed, working mostly in memory:
Sub testSplitInsert()
Dim sh As Worksheet, lastR As Long, arr, arrSp, arrFin, i As Long, j As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
arr = sh.Range("B1:D" & lastR).Value
ReDim arrFin(1 To UBound(arr) * 10, 1 To 3) 'maximum to keep max 10 rows per each case
k = 1 'initialize the variable to load the final array
For i = 1 To UBound(arr)
arrSp = Split(Replace(arr(i, 1)," ",""), ";") 'trim for the case when somebody used Red;Blue, instead of Red; Blue
For j = 0 To UBound(arrSp)
arrFin(k, 1) = arrSp(j): arrFin(k, 3) = arr(i, 3): k = k + 1
Next j
arrSp = Split(Replace(arr(i, 1)," ",""), ";")
For j = 0 To UBound(arrSp)
arrFin(k, 2) = arrSp(j): arrFin(k, 3) = arr(i, 3): k = k + 1
Next j
Next
sh.Range("G1").Resize(k - 1, 3).Value = arrFin
End Sub
It processes the range in columns "B:D" and returns the result in columns "G:I". It can be easily adapted to process any columns range and return even overwriting the existing range, but this should be done only after checking that it return what you need...
i'm trying to move words after the first space from 30th character in a string to the next row(i+1) added and remove those words moved to the next row from the current row(i). The code is giving Run-time error '5': Invalid procedure call or argument error message at Cells(i, 1).Value = Left(Cells(i, 1), InStr(30, Cells(i, 1), " ") - 1) line.
Sub TextLimit_02()
Dim i As Long
Dim CelLen As Long
For i = 1 To 50
CelLen = Len(Cells(i, 1))
If CelLen > 40 Then
Rows(i + 1).Insert
Cells(i + 1, 1).Value = Mid(Cells(i, 1), InStr(30, Cells(i, 1), " ") + 1, Len(Cells(i,
1).Value) - InStr(30, Cells(i, 1), " "))
Cells(i, 1).Value = Left(Cells(i, 1), InStr(30, Cells(i, 1), " ") - 1)
Else
End If
Next i
End Sub
Your code doesn't account for the possibility that in a string longer than 40, there are no spaces after position 30.
Breaking the logic down into steps makes it easy to detect this, and possibly add more code to deal with it
Sub TextLimit_02()
Dim i As Long
Dim CelLen As Long
Dim idx As Long
Dim CellString As String
Dim LeftPart As String
Dim RightPart As String
For i = 1 To 50
CellString = Cells(i, 1).Value2
CelLen = Len(CellString)
If CelLen > 40 Then
idx = InStr(30, CellString, " ")
If idx > 0 Then
Rows(i + 1).Insert
LeftPart = Left$(CellString, idx - 1)
RightPart = Mid$(CellString, idx + 1)
Cells(i, 1) = LeftPart
Cells(i + 1, 1) = RightPart
If idx > 40 Then
' there remains >40 characters in Cells(i, 1)
End If
Else
' No spaces after position 30. Cells(i, 1) remains longer than 40
End If
End If
Next i
End Sub
Note that if you split a lot of strings, your data may end up spanning past row 50. With For i = 1 to 50 you will miss processing some string in that case.
This code should do what you intend. Please test it and let me know what it does wrong.
Sub TextLimit_02()
' 269
Dim Txt As String ' text
Dim Tail As String ' tail end of Txt to be moved
Dim p As Long ' position of character in string
Dim R As Long ' loop counter: rows
Application.ScreenUpdating = False
' start from the end of column A to 2nd row
For R = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
Txt = Trim(Cells(R, "A").Value) ' remove leading/trailing blanks
p = InStr(Mid(Txt, 30), " ")
Tail = Trim(Mid(Txt, p + 30)) ' in case of double space
If Len(Tail) Then ' skip if no Tail
Cells(R, "A").Value = Left(Txt, p + 29)
Rows(R + 1).Insert
Cells(R + 1, "A").Value = Tail
End If
Next R
Application.ScreenUpdating = True
End Sub
Try this code:
Sub WrapText()
Const MIN_CARRY_POS = 30, MAX_LEN = 40, CARRY_SYMBOL = " " 'preferences
Dim cl As Range, txt As String, pos As Long, slice As Long
Application.ScreenUpdating = False
Set cl = ThisWorkbook.Worksheets(1).Range("A1")
Do 'main row loop
txt = RTrim(cl.Text)
Select Case Len(txt)
Case 0: Exit Do
Case Is > MAX_LEN
Do While Len(txt) > MAX_LEN 'a nested loop to process text that needs to be carried over
pos = InStr(MIN_CARRY_POS, txt, CARRY_SYMBOL)
If pos < 1 Then pos = MAX_LEN 'if no CARRY_SYMBOL after MIN_CARRY_POS then cut the string at MAX_LEN
slice = WorksheetFunction.Min(pos, MAX_LEN)
cl.Insert xlDown
cl.Offset(-1).Value = Mid(txt, 1, slice) 'output the head
txt = LTrim(Mid(txt, slice + 1)) 'get the rest of the txt
Loop
cl.Value = txt 'output the rest <= MAX_LEN
End Select
Set cl = cl.Offset(1) 'move to the next row
Loop
Application.ScreenUpdating = True
End Sub
Before
After
I've got a function which merges cells in table if whole range has the same value (eg. if A1:G1 is equal to A2:B2 it will merge cells like A1&A2, B1&B2 etc. More here: How to check if two ranges value is equal)
Now I would like, to change color on table created by that funcion, like first row (doesn't matter if merged or no) filled with color, second blank etc. but I have no idea whether I should color it with merging function or create another which will detect new table with merged rows as one etc. Below is my code:
Sub test()
Dim i As Long, j As Long, k As Long, row As Long
row = Cells(Rows.Count, 2).End(xlUp).row
k = 1
For i = 1 To row Step 1
If Cells(i, 1).Value = "" Then Exit For
If Join(Application.Transpose(Application.Transpose(Range(Cells(i, 1), Cells(i, 3)))), Chr(0)) <> Join(Application.Transpose(Application.Transpose(Range(Cells(i + 1, 1), Cells(i + 1, 3)))), Chr(0)) Then
If i <> k Then
For j = 1 To 3 Step 1
Application.DisplayAlerts = False
Range(Cells(i, j), Cells(k, j)).Merge
Application.DisplayAlerts = True
Next j
End If
k = i + 1
End If
Next i
End Sub
Try:
Option Explicit
Sub test1()
Dim LastColumn As Long, LastRow As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 2 To LastRow Step 2
.Range(Cells(i, 1), .Cells(i, LastColumn)).Interior.Color = vbGreen '<- You could change the color
Next i
End With
End Sub
Before:
After:
Edited Solution:
Option Explicit
Sub test1()
Dim rng As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .UsedRange
.ListObjects.Add(xlSrcRange, rng, , xlYes).Name = "Table1"
.ListObjects("Table1").TableStyle = "TableStyleLight3"
End With
End Sub
Result:
So, after some time I've figured it out by myself. Below is the code:
Dim i As Long, j As Long, k As Long, l As Long, c As Integer
row = Cells(Rows.Count, 2).End(xlUp).row
k = 7
c = 1
For i = 7 To row Step 1
If Join(Application.Transpose(Application.Transpose(Range(Cells(i, 1), Cells(i, 3)))), Chr(0)) <> Join(Application.Transpose(Application.Transpose(Range(Cells(i + 1, 1), Cells(i + 1, 3)))), Chr(0)) Then
If i <> k Then
For j = 1 To 3 Step 1
Application.DisplayAlerts = False
Range(Cells(i, j), Cells(k, j)).Merge
Application.DisplayAlerts = True
Next j
End If
Select Case c
Case 0
Range(Cells(k, 1), Cells(k, 3)).Interior.Color = xlNone
c = 1
Case 1
For l = 0 To i - k Step 1
Range(Cells(k + l, 1), Cells(k + l, 3)).Interior.Color = RGB(217, 225, 242)
Next l
c = 0
End Select
k = i + 1
End If
Next i
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