How to merge several cells using VBA - excel

I have some problems with excel and VBA, in that don't know have much knowledge. I copied text from pdf and it's awful.
I have cells which contain some text.
The problem is that the text from one paragraph is broken down over several cells. At the beginning of each paragraph is a word in bold (e.g. CLR.) which describes the rest of the text. As such, it defines where each paragraph should start. How I can merge these cells into one?
I see
I want

Sub MergeText()
Dim strMerged$, r&, j&, i&
r = 1
Do While True
If Cells(r, 1).Characters(1, 1).Font.Bold Then
strMerged = "": strMerged = Cells(r, 1)
r = r + 1
While (Not Cells(r, 1).Characters(1).Font.Bold) And Len(Cells(r, 1)) > 0
strMerged = strMerged & Cells(r, 1)
r = r + 1
Wend
i = i + 1: Cells(i, 2) = strMerged
Cells(i, 2).Characters(1, InStr(1, strMerged, ".", vbTextCompare)).Font.Bold = True
Else
Exit Do
End If
Loop
End Sub

Modify (if needed) and try:
Option Explicit
Sub test()
Dim LastRow As Long, i As Long, j As Long, Count As Long
Dim str As String
With ThisWorkbook.Worksheets("Sheet1") 'Change sheet name if needed
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 2 Step -1
If (UCase(Left(.Range("A" & i), 1)) <> Left(.Range("A" & i), 1)) And UCase(Left(.Range("A" & i - 1), 1)) = Left(.Range("A" & i - 1), 1) Then
Count = 0
For j = 1 To Len(.Range("A" & i - 1))
If .Range("A1").Characters(j, 1).Font.FontStyle = "Bold" Then
Count = Count + 1
Else
Exit For
End If
Next j
str = .Range("A" & i - 1).Value & " " & .Range("A" & i).Value
With .Range("A" & i - 1)
.Value = str
.Font.Bold = False
With .Characters(Start:=1, Length:=Count).Font
.FontStyle = "Bold"
End With
End With
.Rows(i).EntireRow.Delete
ElseIf (UCase(Left(.Range("A" & i), 1)) <> Left(.Range("A" & i), 1)) And UCase(Left(.Range("A" & i - 1), 1)) <> Left(.Range("A" & i - 1), 1) Then
str = .Range("A" & i - 1).Value & " " & .Range("A" & i).Value
With .Range("A" & i - 1)
.Value = str
.Font.Bold = False
End With
.Rows(i).EntireRow.Delete
End If
Next i
End With
End Sub

Related

How to sort multiple columns sequentially and have the rows merge for the same values?

I have a really crude code for sorting the columns out and merging them together as seen by my code. The first 3 blocks are to sort them first by column A, then column B, and then column C.
I want it so that users can see the breakdown in columns A, B and C. Column A being the material, B being the material variant, and C the fabrication method and not have to look at each entry row by row.
Is there a more efficient way of sorting the columns without having to go through the 3 blocks of code? And merging them at the end for me seems to not work as well and the rows end up getting mixed and not properly sorted.
Dim wsproc As Worksheet: Set wsproc = ThisWorkbook.Worksheets("Procurement Table")
For k3 = wsproc.UsedRange.Rows.Count To 2 Step -1
For i3 = wsproc.UsedRange.Rows.Count To 2 Step -1
If _
wsproc.Cells(k3, 1).Value = wsproc.Cells(i3 - 1, 1).Value _
Then
wsproc.Rows(i3 - 1).Cut
wsproc.Range("A1").End(xlDown).Offset(1, 0).EntireRow.Insert
End If
Next
Next
For k3 = wsproc.UsedRange.Rows.Count To 2 Step -1
For i3 = wsproc.UsedRange.Rows.Count To 2 Step -1
If _
wsproc.Cells(k3, 1).Value = wsproc.Cells(i3 - 1, 1).Value _
And wsproc.Cells(k3, 2).Value = wsproc.Cells(i3 - 1, 2).Value _
Then
wsproc.Rows(i3 - 1).Cut
wsproc.Range("A1").End(xlDown).Offset(1, 0).EntireRow.Insert
End If
Next
Next
For k3 = wsproc.UsedRange.Rows.Count To 2 Step -1
For i3 = wsproc.UsedRange.Rows.Count To 2 Step -1
If _
wsproc.Cells(k3, 1).Value = wsproc.Cells(i3 - 1, 1).Value _
And wsproc.Cells(k3, 2).Value = wsproc.Cells(i3 - 1, 2).Value _
And wsproc.Cells(k3, 3).Value = wsproc.Cells(i3 - 1, 3).Value _
Then
wsproc.Rows(i3 - 1).Cut
wsproc.Range("A1").End(xlDown).Offset(1, 0).EntireRow.Insert
End If
Next
Next
'To merge duplicate rows column-wise
Dim p As Variant
Dim iArray As Variant
Dim l%
iArray = Array(1, 2, 3)
ActiveSheet.ListObjects(1).Unlist
For Each p In iArray
For l = wsproc.UsedRange.Rows.Count To 2 Step -1
If wsproc.Cells(l, p).Value = wsproc.Cells(l - 1, p).Value _
Then
wsproc.Range(wsproc.Cells(l, p), wsproc.Cells(l - 1, p)).Merge
End If
Next
Next p
Range.Sort
Sub Main
Dim sheet as Worksheet: Set sheet = ThisWorkbook.Sheets("Sheet Name")
Dim lastRow as Long
Dim lastColumn as Integer
Dim sheetRange as Range
Dim sheetArray as Variant
Dim mergeRangesArray as Variant
Dim startRows as Variant
Dim i as Long
lastRow = sheet.UsedRange.Rows.Count
lastColumn = sheet.UsedRange.Columns.Count
'Assign the sheet's used range to a variable
Set sheetRange = sheet.Range(sheet.Cells(1, 1), sheet.Cells(lastRow, lastColumn))
'Use the Range.Sort method to sort
sheetRange.Sort key1:=sheet.Range("A1:A" & lastRow), order1:=xlAscending, _
key2:=sheet.Range("B1:B" & lastRow), order2:=xlAscending, _
key3:=sheet.Range("C1:C" & lastRow), order3:=xlAscending, Header:=xlYes
'Assign the sheet's range values to a 2D array
sheetArray = sheetRange
'Loop through the rows of the 2D array, and add ranges that need to be merged
'to the mergeRangesArray. The mergeRangesArray is an array of strings which
'are looped through at the end of the Sub to merge cells.
'The string argument for Range() has a character limit of 255.
startRows = Array(2, 2, 2)
For i = 3 to lastRow
If sheetArray(i, 1) <> sheetArray(i - 1, 1) Then
If i - startRows(0) > 1 Then
Call AddToRangeArray(mergeRangesArray, "A" & startRows(0) & ":A" & i - 1)
If i - startRows(1) > 1 Then
Call AddToRangeArray(mergeRangesArray, "B" & startRows(1) & ":B" & i - 1)
End If
If i - startRows(2) > 1 Then
Call AddToRangeArray(mergeRangesArray, "C" & startRows(2) & ":C" & i - 1)
End If
End If
startRows = Array(i, i, i)
Else
If sheetArray(i, 2) <> sheetArray(i - 1, 2) Then
If i - startRows(1) > 1 Then
Call AddToRangeArray(mergeRangesArray, "B" & startRows(1) & ":B" & i - 1)
End If
startRows(1) = i
End If
If sheetArray(i, 3) <> sheetArray(i - 1, 3) Then
If i - startRows(2) > 1 Then
Call AddToRangeArray(mergeRangesArray, "C" & startRows(2) & ":C" & i - 1)
End If
startRows(2) = i
End If
End If
Next i
If i - startRows(0) > 1 Then
Call AddToRangeArray(mergeRangesArray, "A" & startRows(0) & ":A" & i - 1)
End If
If i - startRows(1) > 1 Then
Call AddToRangeArray(mergeRangesArray, "B" & startRows(1) & ":B" & i - 1)
End If
If i - startRows(2) > 1 Then
Call AddToRangeArray(mergeRangesArray, "C" & startRows(2) & ":C" & i - 1)
End If
Application.DisplayAlerts = False
For i = 1 to UBound(mergeRangesArray)
sheet.Range(mergeRangesArray(i)).Merge
Next i
Application.DisplayAlerts = True
End Sub
Sub AddToRangeArray(mergeRangesArray as variant, myString as string)
Dim i as Integer
Dim j as Integer
If IsEmpty(mergeRangesArray) = False Then
i = UBound(mergeRangesArray)
j = Len(mergeRangesArray(i))
If j + Len("," & myString) <= 255 Then
mergeRangesArray(i) = mergeRangesArray(i) & "," & myString
Else
ReDim Preserve mergeRangesArray(1 to i + 1)
mergeRangesArray(i + 1) = myString
End If
Else
ReDim mergeRangesArray(1 to 1)
mergeRangesArray(1) = myString
End If
End Sub

Dynamic first and last row of a range

I am surprised there's no answer for this. I have read Setting Dynamic Ranges in VBA and Selecting Dynamic Range and Autofill Dynamic Range Last Row and Last Column and MSDN
I have multiple, distinct ranges on a sheet with varying sizes. I am trying to subtotal column L. I can do it using a hardcoded sum (via subtotal variable) but I want to insert a formula into the cell instead. This requires knowing the starting and end rows for each range. My code almost works. It fails when the range only consists of one row. Even so, I feel there's gotta be a smarter way to do this.
How does one determine the start and end row of a range on a sheet filled with multiple ranges?
For i = 2 To j
If .Cells(i + 1, "L") = "" And .Cells(i + 2, "L") = "" Then
b = .Cells(i - 1, "J").End(xlUp).Row
End If
subtotal = subtotal + .Cells(i, "L").Value2
If .Cells(i, 1) = "" And .Cells(i - 1, "B") <> "" Then
If .Cells(i - 1, "K") = 0 Then
.Cells(i, "K").Value2 = "Check Payment"
'Set sumRng = .Range(.Cells(b, "L"), .Cells(i - 1, "L"))
.Cells(i, "L").Formula = "=sum(L" & b & ":L" & i - 1 & ")"
.Cells(i - 1, "L").Borders(xlEdgeBottom).LineStyle = xlContinuous
total = total + subtotal
subtotal = 0
ElseIf .Cells(i - 1, "K") = "Checking" Then
.Cells(i, "K").Value2 = "EFT Payment"
'Set sumRng = .Range(.Cells(b, "L"), .Cells(i - 1, "L"))
.Cells(i, "L").Formula = "=sum(L" & b & ":L" & i - 1 & ")"
.Cells(i - 1, "L").Borders(xlEdgeBottom).LineStyle = xlContinuous
total = total + subtotal
subtotal = 0
End If
End If
Next
You can loop through the column like this:
For i = 2 To mySheet.Range("B" & Rows.Count).End(xlUp).Row + 1
If Range("B" & i).Value <> vbNullString Then
If Range("B" & i - 1).Value = vbNullString Then
j = i
End If
Else
If Range("B" & i - 1).Value <> vbNullString And Range("B" & i - 1).Formula <> "=SUM(B" & j & ":B" & i - 2 & ")" Then
Range("B" & i).Formula = "=SUM(B" & j & ":B" & i - 1 & ")"
End If
End If
Next i
This uses Match to skip chunks and as such the number or loops are less
With ActiveSheet
Dim b As Long
b = 2
Do Until b = .Rows.Count
Dim x As Variant
x = .Evaluate("Match(True, Index(" & .Range(.Cells(b, "l"), .Cells(.Rows.Count, "l")).Address & " <> """",),0)")
If Not IsError(x) Then
b = b + x - 1
Else
Exit Sub
End If
x = .Evaluate("Match(True, Index(" & .Range(.Cells(b, "l"), .Cells(.Rows.Count, "l")).Address & " = """",),0)")
Dim i As Long
i = b + x - 1
.Cells(i, "l").Formula = "=sum(L" & b & ":L" & i - 1 & ")"
b = i + 2
Loop
End With

How can I speed this vba code up which involves formatting?

I am setting up a new pricing schedule which reads selected information from a 'Register' tab, based on selected criteria, and copying this into a new tab. This data is formatted so it looks aesthetically pleasing.
I am finding formatting the code is slowing down the run speed significantly. If possible I would like to speed this up as I will be iterating this multiple times.
I hae sped the program up a reasonable amount. Initially it took 30s, whereas now it is about 10s.
I have followed information from this website as best as I can:
https://www.soa.org/News-and-Publications/Newsletters/Compact/2012/january/com-2012-iss42-roper.aspx
I feel there is still scope to improve more, though I am unsure how, and am reaching out to see if there is, or are, better ways to improve the code so it runs quicker.
Option Explicit
Sub create_pricing_schedule()
'define workbook variables
Dim Start_Time As Double, End_Time As Double
Dim file1 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
Dim namedRange1 As Range
Dim namedRange2 As Range
Set file1 = ThisWorkbook
Set ws2 = file1.Worksheets("Pricing Schedule")
Set ws3 = file1.Worksheets("Control")
Set ws4 = file1.Worksheets("Register")
Set namedRange1 = file1.Names("Client_Register").RefersToRange
Set namedRange2 = file1.Names("Pricing_Range").RefersToRange
'define general variables
Dim i As Integer
Dim collect(1 To 500, 1 To 10) As Variant
Dim rw As Range
Dim selectedClient As String
Dim lastrow As Integer, lastrow2 As Integer, lastrow3 As Integer
i = 1
'time how long it takes to improve efficiency
Start_Time = Timer
'speedup so less lagg
Call speedup
'delete everything from the pricing schedule/reset
With Sheets("Pricing Schedule")
.UsedRange.ClearContents
.Cells.Interior.ColorIndex = 0
.Cells.Borders.LineStyle = xlNone
.Cells.HorizontalAlignment = xlLeft
.Cells.MergeCells = False
.Range("A:Z").WrapText = False
.Rows.RowHeight = "15"
End With
'resize the client register
lastrow = ws4.Range("A100000").End(xlUp).Row
With ActiveWorkbook.Names("Client_Register")
.RefersTo = "=Register!$A$1:$AE$" & lastrow
End With
selectedClient = ws3.Range("B3").Value
'copy from database to the pricing schedule as a non formatted list of all the info - this runs quickly, but I am open to changing it
For Each rw In Range("Client_Register").Rows
If Range("Client_Register").Cells(rw.Row, 2) = selectedClient Then
collect(i, 1) = Range("Client_Register").Range("E" & rw.Row)
collect(i, 2) = Range("Client_Register").Range("D" & rw.Row)
collect(i, 3) = Range("Client_Register").Range("F" & rw.Row)
collect(i, 4) = Range("Client_Register").Range("J" & rw.Row)
collect(i, 5) = Range("Client_Register").Range("K" & rw.Row)
collect(i, 6) = Range("Client_Register").Range("L" & rw.Row)
collect(i, 7) = Range("Client_Register").Range("M" & rw.Row)
collect(i, 8) = Range("Client_Register").Range("P" & rw.Row)
collect(i, 9) = Range("Client_Register").Range("I" & rw.Row)
collect(i, 10) = Range("Client_Register").Range("H" & rw.Row) ' used to determine if pass through fee
ws2.Range("B" & i + 6) = collect(i, 1)
ws2.Range("C" & i + 6) = collect(i, 2)
ws2.Range("D" & i + 6) = collect(i, 3)
ws2.Range("E" & i + 6) = collect(i, 4)
ws2.Range("F" & i + 6) = collect(i, 5)
ws2.Range("G" & i + 6) = collect(i, 6)
ws2.Range("H" & i + 6) = collect(i, 7)
ws2.Range("I" & i + 6) = collect(i, 8)
ws2.Range("J" & i + 6) = collect(i, 9)
ws2.Range("K" & i + 6) = collect(i, 10)
i = i + 1
End If
Next
'add in the colour and count how many rows there are
lastrow2 = ws2.Range("C5000").End(xlUp).Row
With ActiveWorkbook.Names("Pricing_Range")
.RefersTo = "='Pricing Schedule'!$A$1:$K$" & lastrow2
End With
ws2.Range("B7" & ":" & "J" & lastrow2).Interior.Color = RGB(242, 242, 242)
'==========this bit is slow, can it be quicker?==========
'add spacing, titles, and colour to sub headers
i = 7
For Each rw In Range("Pricing_Range").Rows
If Range("Pricing_Range").Cells(i, 3) <> Range("Pricing_Range").Cells(i + 1, 3) Then
Range("Pricing_Range").Rows(i + 1).Insert Shift:=xlShiftDown
Range("Pricing_Range").Rows(i + 1).Insert Shift:=xlShiftDown
Range("Pricing_Range").Rows(i + 1).Interior.ColorIndex = 0
Range("Pricing_Range").Rows(i + 2).Interior.ColorIndex = 0
Range("Pricing_Range").Range("B" & i + 2 & ":" & "J" & i + 2).Interior.Color = RGB(255, 128, 1)
Range("Pricing_Range").Range("B" & i + 2 & ":" & "J" & i + 2).Borders(xlEdgeTop).Color = RGB(0, 0, 0)
Range("Pricing_Range").Range("B" & i + 2 & ":" & "J" & i + 2).Borders(xlEdgeBottom).Color = RGB(0, 0, 0)
Range("Pricing_Range").Range("B" & i + 2).Value = Range("Pricing_Range").Range("C" & i + 3).Value
'if it is a pass through fee then add it in to the sub headers
If Range("Pricing_Range").Range("K" & i + 3).Value = "Pass-Through" Then
Range("Pricing_Range").Range("J" & i + 2).Value = "Pass-Through Fees"
Range("Pricing_Range").Range("J" & i + 2).HorizontalAlignment = xlRight
End If
i = i + 3
Else
i = i + 1
End If
Next
'==================================================
'set up the main title rows
ws2.Select
Range("Pricing_Range").Range("B2").Value = ws3.Range("B3").Value
Range("Pricing_Range").Range("B2").Font.Size = 20
Range("Pricing_Range").Range("B2").Font.Bold = True
Range("Pricing_Range").Range("B2").Font.FontStyle = "Calibri Light"
Range("Pricing_Range").Range("B2:J3").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.MergeCells = True
.Cells.Interior.Color = RGB(255, 128, 1)
.Cells.Borders(xlEdgeTop).Color = RGB(0, 0, 0)
.Cells.Borders(xlEdgeBottom).Color = RGB(0, 0, 0)
End With
'tidy up things in the sheet
With Worksheets("Pricing Schedule")
'set up the headers and first title
.Range("B6") = .Range("C7")
.Range("B5:J6").Interior.Color = RGB(255, 128, 1)
.Range("B5:J5").Borders(xlEdgeTop).Color = RGB(0, 0, 0)
.Range("B5:J5").Borders(xlEdgeBottom).Color = RGB(0, 0, 0)
.Range("B6:J6").Borders(xlEdgeTop).Color = RGB(0, 0, 0)
.Range("B6:J6").Borders(xlEdgeBottom).Color = RGB(0, 0, 0)
.Range("B5").Value = "Fee Code"
.Range("C5").Value = "Product Line"
.Range("D5").Value = "Item"
.Range("E5").Value = "Volume From"
.Range("F5").Value = "Volume To"
.Range("G5").Value = "Frequency"
.Range("H5").Value = "Location"
.Range("I5").Value = "Price"
.Range("J5").Value = "Nature of Fee"
'tidy up column widths
.Range("A5").RowHeight = 30
.Range("A1").ColumnWidth = 2
.Range("B1").ColumnWidth = 15
.Range("C1").ColumnWidth = 40
.Range("D1").ColumnWidth = 45
.Range("E1").ColumnWidth = 11
.Range("F1").ColumnWidth = 11
.Range("G1").ColumnWidth = 35
.Range("H1").ColumnWidth = 15
.Range("I1").ColumnWidth = 12
.Range("J1").ColumnWidth = 50
.Range("J:J").WrapText = True
.Range("K:K").Delete
End With
'clear the extra orange line at the end
lastrow3 = ws2.Range("B1000").End(xlUp).Row
With ws2.Rows(lastrow3 + 2)
.Cells.Interior.ColorIndex = 0
.Cells.Borders.LineStyle = xlNone
.ClearContents
End With
'add print area
With Worksheets("Pricing Schedule")
.PageSetup.Zoom = False
.PageSetup.Orientation = xlPortrait
.PageSetup.PrintArea = "$B$2:$J$" & lastrow3
.PageSetup.FitToPagesWide = 1
.PageSetup.FitToPagesTall = False
.PageSetup.PrintTitleRows = "$2:$6"
End With
'return to normal
Call slowdown
'time how long it takes to improve efficiency
End_Time = Timer
Worksheets("Control").Cells(6, 2) = End_Time - Start_Time
End Sub
Sub speedup()
Application.Calculation = xlManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
End Sub
Sub slowdown()
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayStatusBar = True
End Sub
I found a few lines that could save you some execution time.
'****EDIT****Changed this to direct range reference rather than go through the Names collection.
'Set namedRange1 = file1.Names("Client_Register").RefersToRange
'Set namedRange2 = file1.Names("Pricing_Range").RefersToRange
Set namedRange1 = file1.Range("Client_Register")
Set namedRange2 = file1.Range("Pricing_Range")
Used range takes more time rather use .cells directly
'delete everything from the pricing schedule/reset
'****EDIT***
With ws2 'Sheets("Pricing Schedule")
'used range takes more time rather use .cells directly
.Cells.ClearContents
Rather than use arrays you can directly update values as shown below
'I am using i for the row count
ws2.Range("B" & i + 6).Value = namedRange1.Cells(i, 5).Value
ws2.Range("C" & i + 6).Value = namedRange1.Cells(i, 4).Value
ws2.Range("D" & i + 6).Value = namedRange1.Cells(i, 6).Value
ws2.Range("E" & i + 6).Value = namedRange1.Cells(i, 10).Value
ws2.Range("F" & i + 6).Value = namedRange1.Cells(i, 11).Value
ws2.Range("G" & i + 6).Value = namedRange1.Cells(i, 12).Value
ws2.Range("H" & i + 6).Value = namedRange1.Cells(i, 12).Value
ws2.Range("I" & i + 6).Value = namedRange1.Cells(i, 16).Value
ws2.Range("J" & i + 6).Value = namedRange1.Cells(i, 9).Value
ws2.Range("K" & i + 6).Value = namedRange1.Cells(i, 8).Value
i = i + 1
The main culprit for your slower performance is the insert operation. try to work the logic to not having insert. If not possible, try to insert rows outside the loop in a single operation rather than in the loop
Range("Pricing_Range").Rows(i + 1).Insert Shift:=xlShiftDown
Range("Pricing_Range").Rows(i + 1).Insert Shift:=xlShiftDown
Your handling of the collect array is inefficient. Consider reading the entire Client Register into an array with MyArray = Range.Value. Then prepare the output array in memory and write it to the worksheet after all looping is done, in one go, with TargetRange.Value = collect.
Avoid inserting rows. What's wrong with the existing? If you are preparing all data in an array to be pasted to the worksheet, empty array elements will produce empty worksheet cells. In this way all inserting can be avoided and all you need to do is to format.
There is time cost for every access to the worksheet, whether to read or write. Even for formatting, try to create ranges that are treated in the same manner. Avoid accessing the worksheet in loops.
Example of With and block assignment from an array:
'copy from database to the pricing schedule as a
' non formatted list of all the info - this runs quickly,
' but I am open to changing it
With Range("Client_Register")
For Each rw In .Rows
If .Cells(rw.Row, 2) = selectedClient Then
collect(i, 1) = .Range("E" & rw.Row)
collect(i, 2) = .Range("D" & rw.Row)
collect(i, 3) = .Range("F" & rw.Row)
collect(i, 4) = .Range("J" & rw.Row)
collect(i, 5) = .Range("K" & rw.Row)
collect(i, 6) = .Range("L" & rw.Row)
collect(i, 7) = .Range("M" & rw.Row)
collect(i, 8) = .Range("P" & rw.Row)
collect(i, 9) = .Range("I" & rw.Row)
collect(i, 10) = .Range("H" & rw.Row)
'you could even skip the row-by-row population of values
' and assign as a block after exiting the loop
ws2.Range("B" & i + 6).Resize(1, 10).Value = _
Array(collect(i, 1), collect(i, 2), collect(i, 3), _
collect(i, 4), collect(i, 5), collect(i, 6), _
collect(i, 7), collect(i, 8), collect(i, 9), _
collect(i, 10))
i = i + 1
End If
Next
End With
Note this will break if your Client_Register refers to a range which doesn't start on Row1, because of the relative range references.
Eg:
Range("A1:A10").Range("A1") 'refers to A1
Range("A2:A10").Range("A1") 'refers to A2

Creating new rows in excel with From and To values

I currently have a sheet with two columns - 'From' and 'To'. I am trying to create a spreadsheet where each line is an individual value that falls within the ranges currently in each row.
An example (sorry I cannot embed images yet)--
What I have:
What I want:
Try this VBA code,
Sub splitToCodes()
Dim i As Long, j As Long, k As Long
j = 2
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If IsNumeric(Cells(i, 1)) Then
For k = Cells(i, 1) To Cells(i, 2)
Cells(j, 4) = k
j = j + 1
Next k
Else
For k = Right(Cells(i, 1), Len(Cells(i, 1)) - 1) To Right(Cells(i, 2), Len(Cells(i, 2)) - 1)
Cells(j, 4) = k
Cells(j, 4) = Left(Cells(i, 1), Len(Cells(i, 1)) - Len(Cells(j, 4))) & k
j = j + 1
Next k
End If
Next i
End Sub
This code loops through the columns A and B and prints the output in column D. Modify as per your needs.
Note:- This code will work only for similar data as in the image as you have not mentioned any other format.
Copy & paste FROM and TO columns under each other and apply remove duplicates function at data block of menu bar.
Here is my super tedious solution:
Option Explicit
Sub Test()
Dim i As Integer, j As Integer, k As Long, sht As Worksheet, lastrow As Long, missingzeroes As Integer, zeroesholder As String, myzeroes As String
Set sht = ThisWorkbook.Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastrow
If IsNumeric(Range("B" & i).Value) = True And IsNumeric(Range("A" & i).Value) = True Then
j = Range("B" & i).Value - Range("A" & i).Value
lastrow = sht.Cells(sht.Rows.Count, "D").End(xlUp).Row
For k = 0 To j
Range("D" & lastrow + 1 + k).Value = Range("A" & i).Value + k
Next k
Else
j = Right(Range("B" & i).Value, 4) - Right(Range("A" & i).Value, 4)
lastrow = sht.Cells(sht.Rows.Count, "D").End(xlUp).Row
For k = 0 To j
Range("D" & lastrow + 1 + k).Value = Left(Range("B" & i).Value, 1) & Right(Range("A" & i).Value, 4) + k
If Len(Range("B" & i).Value) <> Len(Range("D" & lastrow + 1 + k).Value) Then
missingzeroes = Len(Range("B" & i).Value) - Len(Range("D" & lastrow + 1 + k).Value)
zeroesholder = "000000000000000000000000000000000000000000000000000000000000000000"
myzeroes = Left(zeroesholder, missingzeroes)
Range("D" & lastrow + 1 + k).Value = Left(Range("A" & i).Value, 1) & myzeroes & Right(Range("A" & i).Value, Len(Range("D" & lastrow + 1 + k).Value) - 1) + k
End If
Next k
End If
Next i
End Sub

Do While Loop for SKU numbers

I am trying to automate my SKU numbers. I have 3 columns. The first column has 28, the second has 6 and finally the third has 58.
I want the SKU to have a Trend like so 0{(###)col1}{(##)col2}{(##)col3}0
My Code looks like this
Sub SKU()
Dim x As Long
x = 1
i = 1
j = 1
k = 1
Do While Cells(i, 1) <> ""
Do While Cells(j, 2) <> ""
Do While Cells(k, 3) <> ""
Cells(x, 4).Value = Format(0, "0") & Format(i, "000") & _
Format(j, "00") & Format(k, "00") & Format(0, "0")
k = k + 1
x = x + 1
Loop
j = j + 1
Loop
i = i + 1
Loop
End Sub
No need to use the Do Loop. Find the last row and then use a For loop.
Is this what you are trying?
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet2")
With ws
'~~> Find last row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
If .Cells(i, 1) <> "" And .Cells(i, 2) <> "" And .Cells(i, 3) <> "" Then
'0{(###)col1}{(##)col2}{(##)col3}0
.Cells(i, 4).Value = "'0" & _
Format(.Cells(i, 1), "000") & _
Format(.Cells(i, 2), "00") & _
Format(.Cells(i, 3), "00") & _
"0"
End If
Next i
End With
End Sub
Output for 28,6,58 is 002806580
As i mentioned in the comment to the question, remove first and second do-while loop then replace:
Cells(x, 4).Value = Format(0, "0") & Format(i, "000") & _
Format(j, "00") & Format(k, "00") & Format(0, "0")
with:
Cells(k, 4) = "'" & Format(Cells(k, 1), "000") & _
Format(Cells(k, 2), "00") & Format(Cells(k, 3), "00")
Result: 0280658
In case you want to add leading and ending zeros:
Cells(k, 4) = "'0" & Format(Cells(k, 1), "000") & _
Format(Cells(k, 2), "00") & Format(Cells(k, 3), "00") & "0"
Result: 002806580

Resources