I'm trying to add lines depending on the input of an individual but when input is entered the first line works fine but every piece of information after adds extra lines to the excel sheet.
Sub InsertRows()
Dim x As Integer
Dim y As Integer
Do
'Retrieve an answer from the user
x = Application.InputBox("Number of Lines Per skid", "Number of lines per skid", Type:=1)
y = Application.InputBox("Skid Number", " What is the skid number", Type:=1)
'Check if user selected cancel button
If x = 0 Then Exit Sub
Range("3:3", Range("A3").Offset(x - 1, 0)).EntireRow.Insert Shift:=xlDown
Range("A3").Value = y
Rows("3:268").Select
Selection.RowHeight = 15.75
Range("A3").Select
Range("A3", Range("A3").Offset(x - 1, 0)).Merge
Range("B3", Range("B3").Offset(x - 1, 0)).Merge
Range("C3", Range("C3").Offset(x - 1, 0)).Merge
Range("D3", Range("D3").Offset(x - 1, 0)).Merge
Range("E3", Range("E3").Offset(x - 1, 0)).Merge
Range("F3", Range("F3").Offset(x - 1, 0)).Merge
Range("G3", Range("G3").Offset(x - 1, 0)).Merge
Range("H3", Range("H3").Offset(x - 1, 0)).Merge
Loop While x > 0 Or x < 24
End Sub
I am not sure about why insertings multiple rows at once does not work but with a for-loop you´ll solve this.
Sub InsertRows()
Dim x As Integer
Dim y As Integer
Dim row As Integer
Dim col As Integer
Do
'Retrieve an answer from the user
x = Application.InputBox("Number of Lines Per skid", "Number of lines per skid", Type:=1)
y = Application.InputBox("Skid Number", " What is the skid number", Type:=1)
'Check if user selected cancel button
If x = 0 Then Exit Sub
'insert rows with a loop
For row = 1 To x
Range("3:3").EntireRow.Insert Shift:=xlDown
Next row
Range("A3").Value = y
'merge columns with a loop
For col = 1 To 8
Range(Cells(3, col), Cells(3 + x - 1, col)).Merge
Next col
'??? make sure you loop is correct, this does not work properly
'x will always be bigger than zero OR smaller than 24
Loop While x > 0 Or x < 24
'just take all the cells an once, altering the RowHeight / no Selection needed.
Cells.RowHeight = 15.75
End Sub
Related
Actually I have converted a pdf to excel. After conversion the next line is converted in next row. I want to merge contents on following condition.
If row1 & row2 has text then put contents of row2 in row1 (in addition to existing) and clear contents of row2. If row2 is blank it should keep contents of row1 and move on to next row.
I have tried two macros. But they are not giving desired output
Sub cc()
Dim X As Integer
For X = 1 To 500
'If Sheet2.Cells(X + 1, 1) isNotBlank Then
If Not IsEmpty(Sheet2.Cells(X + 1, 1).Value) And Not IsEmpty(Sheet2.Cells(X, 1).Value) Then
Sheet2.Cells(X + 1, 1).ClearContents
End If
Next
End Sub
Sub ccc()
Dim X As Integer
For X = 1 To 500
'If Sheet2.Cells(X + 1, 1) isNotBlank Then
If Not IsEmpty(Sheet2.Cells(X + 1, 1).Value) And Not IsEmpty(Sheet2.Cells(X, 1).Value) Then
If Not IsEmpty(Sheet2.Cells(X, 1).Value) Then
Sheet2.Cells(X, 1).Value = Sheet2.Cells(X, 1)
Sheet2.Cells(X + 1, 1).ClearContents
End If
Next
End Sub
I have a matrix, let's say 5 columns and 10 rows.
Then I have 30 stars. I want to put them into the matrix so that the number of stars on each row is the same and the number of stars on each column is the same (3 stars each row and 6 stars each column).
If I have 40 stars, there should be 4 stars each row and 8 stars each column.
I can do the matrix by hand and I really did both cases. But the bigger the matrix is, the harder I fill the stars.
I suppose there should be a principle behind it but still haven't figure it out.
I am using VBA in Excel to generate the 5x10 matrix with 30 stars, but it takes some minutes to try all possibilities with a loop.
Sub test()
Dim xRange As Range
Set xRange = Selection
GoTo FillX
GoTo CheckRows
FillX:
xRange.Clear
xRange.HorizontalAlignment = xlCenter
For i1 = 1 To 5
For i2 = 1 To 6
v = Int(Rnd() * 10 + 1)
While xRange.Cells(v, i1).Value = "x"
v = Int(Rnd() * 10 + 1)
Wend
xRange.Cells(v, i1).Value = "x"
Next
Next
CheckRows:
x = 0
For Each Row In xRange.Rows
If WorksheetFunction.CountA(Row) <> 3 Then
x = x + 1
End If
Next
While x <> 0
GoTo FillX
GoTo CheckRows
Wend
End Sub
Is there a solution which can randomly distribute stars to a range of any size?
Goto should be avoided. Use loops instead.
This code first calculates the number of stars for each row, then uses nested loops to enter them, so there are never more stars in a row. By stepping to the next row, but retaining the column position, and then starting in the same row in the first column, you can ensure that there are no more than the defined number of stars in a column, either. The blank cells will travel diagonally from top left to right. You can see this when you apply conditional formatting.
With this pattern, you don't need to use trial and error and the code runs super fast.
Sub test()
Dim gridRows As Long, gridColumns As Long, Stars As Long
Dim myRow As Long, myColumn As Long
Dim i As Long, j As Long
Dim rowCounter As Long, columnCounter As Long, rowOffset As Long
Dim ws As Worksheet
Set ws = Me
'You can get the grid rows and columns and the number of stars from
' user input or from worksheet cells in you want. Just make sure
' they end up in the variables below.
gridRows = 20
gridColumns = 10
Stars = 60
mycolumns = Stars / gridRows
myRows = Stars / gridColumns
j = 1
rowCounter = 1
columnCounter = 1
ws.Range("A1:zz9990").ClearContents
For j = 1 To gridRows
rowOffset = 0
For i = 1 To gridColumns
ws.Cells(j, i) = 1
columnCounter = columnCounter + 1
If columnCounter > mycolumns Then
j = j + 1
columnCounter = 1
rowOffset = 1
End If
Next i
j = j - rowOffset
Next j
' randomize the results
Dim SortRange As Range
' randomize the columns
Set SortRange = ws.Range(ws.Cells(gridRows + 1, 1), ws.Cells(gridRows + 1, gridColumns))
' enter random numbers
For Each cel In SortRange
Debug.Print cel.Address
cel.Value = Rnd
Next cel
' sort left to right
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add2 Key:=SortRange _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ws.Sort
.SetRange Range("A1", Cells(gridRows + 1, gridColumns))
.Header = xlGuess
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
' clear the random numbers
SortRange.ClearContents
Set SortRange = ws.Range(ws.Cells(1, gridColumns + 1), ws.Cells(gridRows, gridColumns + 1))
' randomize the rows
' enter random numbers
For Each cel In SortRange
Debug.Print cel.Address
cel.Value = Rnd
Next cel
'Sort Rows
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add2 Key:=SortRange _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ws.Sort
.SetRange Range("A1", Cells(gridRows, gridColumns + 1))
.Header = xlGuess
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' clear the random numbers
SortRange.ClearContents
End Sub
Edit after comment: Added code to randomize the results. Add a row with random numbers to the end of the table, sort by those random numbers left to right, and remove them again. Do the same with a column of random numbers and sort top to bottom, then remove the helper numbers.
The screenshot shows a grid with 20 rows, 10 columns and 60 stars using conditional formatting to show the distribution better.
A grid with 60 rows, 30 columns and 1200 stars takes less than a second to build (without using conditional formatting).
This code works a lot quicker (under 1 second mostly).
Sub Button1_Click()
Set xRange = [a1:e10]
x = 0
While x < 6
xRange.Clear
xRange.HorizontalAlignment = xlCenter
For i1 = 1 To 4
For i2 = 1 To 6
Do
g3 = False
Do
v = Int(Rnd * 10 + 1)
Loop While xRange.Cells(v, i1).Value = "x"
xRange.Cells(v, i1).Value = "x"
If WorksheetFunction.CountA(xRange.Rows(v)) > 3 Then
xRange.Cells(v, i1).Value = " "
g3 = True
End If
Loop While g3 = True
xRange.Cells(v, i1).Value = "x"
Next i2
Next i1
x = 0
For Each Row In xRange.Rows
If WorksheetFunction.CountA(Row) = 2 Then x = x + 1
Next Row
Wend
For i2 = 1 To 6
Do
g3 = False
Do
v = Int(Rnd * 10 + 1)
Loop While xRange.Cells(v, 5).Value = "x"
xRange.Cells(v, 5).Value = "x"
If WorksheetFunction.CountA(xRange.Rows(v)) > 3 Then
xRange.Cells(v, i1).Value = " "
g3 = True
End If
Loop While g3 = True
xRange.Cells(v, 5).Value = "x"
Next i2
End Sub
It performs a condition on the rows as well, checking that they have no more than 3 stars in them.
This is done for the first four rows, and then it checks to see if there are at least 6 rows in the last column that can take another star (i.e. have exactly 2 stars already).
My code mostly works but it's taking a while to debug so I am beginning to think my architecture may be flawed XD So how can I architect this better?
I have groups of data separated by a blank row. You can tell each group apart by the ID in column C in addition to the blank row. For each ID, I have various numbers in column B that I need to capture. Sometimes those numbers only start with 5, sometimes it starts with 7. I need to capture the 5 and the 7 separately.
With projWS
With .Range("C1:C6000")
Set f = .Find(cc, LookIn:=xlValues, lookat:=xlPart)
End With
If Not f Is Nothing Then 'first occurence found
counter = 0
i = f.Row
Do
acct = .Cells(i, 2)
If (Len(projWS.Cells(i, 3)) < 1 Or Left(acct, 1) = "7") And done = False Then
acctStart = f.Row
acctRows = i - acctStart
Set acctRng = .Range(.Cells(acctStart, 2), .Cells(i - 1, 5))
Set amountRng = .Range(.Cells(acctStart, 7), .Cells(i - 1, 8))
done = True 'set flag to show range has been filled
End If
counter = counter + 1 'increment counter
i = i + 1 'move to next row
Loop Until Len(.Cells(i, 3)) < 1 'keep looping until blank row
End If
If counter - 1 > acctRows Then 'how we determine if there's a "7"
flag = True 'so we set flag to true
Set depreRng = Range(.Cells(acctStart + acctRows, 2), .Cells(i - 1, 8))
dep = depreRng.Value2 'store range into array
End If
End With
After capture, I need to drop it into another worksheet. This worksheet already has a block of 7 built in. Hence this is the loop I am using to drop the range of 7. There is no built in block for the 5.
For r = 112 To 120
For k = 1 To UBound(dep())
If .Cells(r, 1).Value2 = Trim(dep(k, 1)) Then
Debug.Print .Cells(r, 1).Value2
.Cells(r, 6) = dep(k, 6)
.Cells(r, 7) = dep(k, 7)
Exit For
Else
.Cells(r, 6) = 0
.Cells(r, 7) = 0
End If
Next k
Next r
I have debugged several errors already. The current one is that depreRng is breaking because my math is bad. Instead of debugging each error as I stumble onto it, how can I architect this better?
Ok, my approach it's different. First i use a filter for find the range of rows with the index you are looking for and then loop inside this filtered rows for find the 5xx and the 7xx range. The code:
Sub Macro1()
Dim rng_5xx_start, rng_5xx_stop, rng_7xx_start, rng_7xx_stop As Integer
rng_5xx_start = 0
rng_5xx_stop = 0
rng_7xx_start = 0
rng_7xx_stop = 0
Dim range_5xx, range_7xx As String
'filter for the index you are looking for
'specify the maximum range, the field is the "offset" from the column B (the firts of the range), so for filter for column C you need to put 2, criteria...is the critera :)
ActiveSheet.Range("$B$1:$H$6000").AutoFilter Field:=2, Criteria1:="b"
'the filter returns only the rows with the specifyed index, now a for inside this rows for find the 5xx and the 7xx sub-ranges
For Each Row In ActiveSheet.Range("b1:b6000").SpecialCells(xlCellTypeVisible)
If Cells(Row.Row, 2).Value > 4999 And Cells(Row.Row, 2).Value < 6000 Then
'or any test for understnd if i'm in the 5xx range, if you prefer use the strings use something like left(cells(row.row,2).value,1) = "5"
If rng_5xx_start = 0 Then 'found the first row with a 5xx value
rng_5xx_start = Row.Row 'set the start of the range to this row
End If
If rng_5xx_stop < Row.Row Then 'the row where i am is in the 5xx range and is grater than the current end i noticed
rng_5xx_stop = Row.Row 'refresh the end of the range...at the end this will have the last number of row of the 5xx range
End If
End If
If Cells(Row.Row, 2).Value > 6999 And Cells(Row.Row, 2).Value < 8000 Then
'same as above but for 7xx range
If rng_7xx_start = 0 Then
rng_7xx_start = Row.Row
End If
If rng_7xx_stop < Row.Row Then
rng_7xx_stop = Row.Row
End If
End If
Next
If rng_5xx_start = 0 Then
'not found 5xx rows
range_5xx = "" 'or False, or what you prefer...
Else
range_5xx = "B" & rng_5xx_start & ":H" & rng_5xx_stop
End If
If rng_7xx_start = 0 Then
'not found 7xx rows
range_7xx = "" 'or False, or what you prefer...
Else
range_7xx = "B" & rng_7xx_start & ":H" & rng_7xx_stop
End If
End Sub
That's how i would imagine a macro for your job ;)
Edit 1:
I forgot that this will leave the sheet with the filter on...use activesheet.showalldata for show all the rows and not only the filtered ones
Edit 2:
The tests
If rng_5xx_stop < Row.Row Then
rng_5xx_stop = Row.Row
End If
and
If rng_7xx_stop < Row.Row Then
rng_7xx_stop = Row.Row
End If
are not necessary, it's enough do rng_5xx_stop = Row.Row and rng_7xx_stop = Row.Row and save the two IF statements
You are grouping cells based on the first number of the cell values in column B (I am assuming that they can never be letters). If that is the case, then you can create an array of 0 to 9 and store your ranges in there. Then go through the range.areas in order to get the groupings you're looking for (as highlighted in your screenshot).
To do this, something like this is all you need. I commented code to try to explain it more:
Sub tgr()
Dim wsData As Worksheet
Dim rColB As Range
Dim BCell As Range
Dim aRanges(0 To 9) As Range
Dim SubGroup As Range
Dim lRangeNum As Long
Dim i As Long
'Change to your actual worksheet
Set wsData = ActiveWorkbook.ActiveSheet
'Change to your actual column range, this is based off the sample data
Set rColB = wsData.Range("B1", wsData.Cells(wsData.Rows.Count, "B").End(xlUp))
'Loop through the column range
For Each BCell In rColB.Cells
'Make sure the cell is populated and the starting character is numeric
If Len(BCell.Value) > 0 And IsNumeric(Left(BCell.Value, 1)) Then
'Get the starting digit
lRangeNum = Val(Left(BCell.Value, 1))
'Check if any ranges have been assigned to that array index location
'If not, start a range at that array index
'If so, combine the ranges with Union
Select Case (aRanges(lRangeNum) Is Nothing)
Case True: Set aRanges(lRangeNum) = BCell
Case Else: Set aRanges(lRangeNum) = Union(aRanges(lRangeNum), BCell)
End Select
End If
Next BCell
'You can use any method you want to access the ranges, this just loops
'through the array indices and displays the range areas of each
For i = 0 To 9
If Not aRanges(i) Is Nothing Then
For Each SubGroup In aRanges(i).Areas
'Do what you want with it here
'This just selects the subgroup so you can see it found the groups properly
SubGroup.Select
MsgBox SubGroup.Address
Next SubGroup
End If
Next i
End Sub
I see you've allready rewritten your code, but I'd like to offer how I would do it and would like to know your thoughts about it. Would this be inefficient? I guess it could be because you have to read the first character in cells 4 times for every increment, but not shure if that is a big problem.
Dim start_row As Long
Dim end_row As Long
start_row = 1
end_row = 0
For i = 2 To Range("B" & Rows.Count).End(xlUp).Row
If Cells(i - 1, 2) = "" Then
start_row = i
ElseIf Left(Cells(i - 1, 2), 1) <> Left(Cells(i, 2), 1) Then
start_row = i
End If
If Cells(i + 1, 2) = "" Then
end_row = i
ElseIf Left(Cells(i + 1, 2), 1) <> Left(Cells(i, 2), 1) Then
end_row = i
End If
If end_row <> 0 Then
Call copy_range(start_row, end_row)
end_row = 0
End If
Next i
Another approach that lets you only read the character once could be
Dim start_row As Long
Dim end_row As Long
Dim char_above As String
Dim this_char As String
start_row = 1
end_row = 1
For i = 1 To Range("B" & Rows.Count).End(xlUp).Row
If Cells(i, 2) = "" Then
end_row = i - 1
if i <>1 then Call copy_range(start_row, end_row,char_above)
start_row = i + 1
Else
this_char = Left(Cells(i, 2), 1)
If this_char <> char_above Then
end_row = i - 1
if i<> 1 then Call copy_range(start_row, end_row,char_above)
start_row = i
End If
char_above = this_char
End If
Next i
Let me know your thoughts.
I need to delete columns in a spreadsheet using a loop instead of manually hardcoding those columns in. However all I get is a very unhelpful Next without For error.
Sub test()
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim colNum2 As Integer
colNum2 = 1
For x = 1 To 32
If Range("A1").Value = "Order No." Then
Next colNum
ElseIf Range("B1").Value = "Line No." Then
Next colNum
ElseIf Range("C1").Value = "Order Qty." Then
Next x
ElseIf Range("D1").Value = "PO" Then
Next x
ElseIf Range("E1").Value = "Sched Date" Then
Next x
ElseIf Range("F1").Value = "Sched MFG Line" Then
Next x
ElseIf Range("G1").Value = "Item No." Then
Next x
ElseIf Range("H1").Value = "Item Width" Then
Next x
ElseIf Range("I1").Value = "Item Height" Then
Next x
ElseIf Range("J1").Value = "SL Color" Then
Next x
ElseIf Range("K1").Value = "Frame Option" Then
Next x
End If
'Checks if the cell matches a specific string required by the sorter
'if TRUE should skip through to the next increment of colNum
Columns(colNum2).EntireColumn.Delete
'uses the current number of colNum to delete the current column number
colNum2 = colNum2 + 1
Next x
'increments colNum by one
'Iterates next through the loop
I feel like this would work with say Java or Python so I'm really irritated VBA won't let me do this.
Can someone please explain what is going wrong with this code?
Just use var = var + 1 instead of Next. Next ends the For cycle.
Also you don't need to repeat the variable name on the Next line since it's already in the For line. (For i = 0 To 5 ... Next)
For x = 1 To 32
If Range("A1").Value = "Order No." Then
colNum = colNum +1
ElseIf Range("C1").Value = "Order Qty." Then
x = x + 1
End If
Next
Keep in mind what Scott Cranner said, the Next will also do x=x+1, so if you only want to increment once per cycle, use the Do While cycle instead
x = 1
Do While x <= 32
If Range("A1").Value = "Order No." Then
colNum = colNum +1
ElseIf Range("C1").Value = "Order Qty." Then
x = x + 1
End If
Loop
It seems to me that you want to delete all of the columns that do not match 'a specific string required by the sorter'. In that case, you could loop through all of the columns header labels, deleting the ones that do not match or use a custom left-to-right sort to put all of the non-matching columns to the right and delete then en masse.
Method 1 - Delete non-matching columns
Sub test1()
Dim c As Long, vCOLs As Variant
vCOLs = Array("Order No.", "Line No.", "Order Qty.", "PO", _
"Sched Date", "Sched MFG Line", "Item No.", _
"Item Width", "Item Height", "SL Color", "Frame Option")
With Application
'.ScreenUpdating = False
'.EnableEvents = False
End With
With Worksheets("sheet1")
With .Cells(1, 1).CurrentRegion
'delete from right-to-left or risk missing one
For c = .Columns.Count To 1 Step -1
If IsError(Application.Match(.Cells(1, c).Value2, vCOLs, 0)) Then
.Columns(c).EntireColumn.Delete
End If
Next c
End With
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Method 2 - Custom sort, then offset and delete
Sub test2()
Dim vCOLs As Variant
vCOLs = Array("Order No.", "Line No.", "Order Qty.", "PO", _
"Sched Date", "Sched MFG Line", "Item No.", _
"Item Width", "Item Height", "SL Color", "Frame Option")
With Application
'.ScreenUpdating = False
'.EnableEvents = False
.AddCustomList ListArray:=vCOLs
End With
With Worksheets("sheet1")
With .Cells(1, 1).CurrentRegion
'custom sort to bring the important fields to the left
.Cells.Sort Key1:=.Rows(1), Order1:=xlAscending, _
Orientation:=xlLeftToRight, Header:=xlNo, _
OrderCustom:=Application.GetCustomListNum(vCOLs)
'offset and delete the unwanted columns
With .Offset(0, Application.Match(vCOLs(UBound(vCOLs)), .Rows(1), 0))
.EntireColumn.Delete
End With
End With
End With
With Application
.DeleteCustomList .GetCustomListNum(vCOLs)
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
With either method you are simply listing the columns you want to keep and removing the rest.
There is a twist between .Cells.Sort.SortFields.Add and .Cells.Sort that usually generates some confusion. The .SortFields.Add method uses a CustomOrder:= parameter and the Range.Sort method uses a OrderCustom:= parameter. The two are most definitely NOT the same but often get used interchangeably with disastrous results.
I suspect you are trying to delete columns based on their text values in row 1. This will give you what you want, just put all the text references that you want to delete in the CASE statement.
Option Explicit
Sub DeleteColumns()
Dim colNum As Integer
colNum = 1
Do While Range(alphaCon(colNum) & 1).Value <> ""
Select Case Range(alphaCon(colNum) & 1).Value
Case "ColumnIDontWant", "AnotherColumnIDontWant"
Columns(colNum).EntireColumn.Delete
End Select
colNum = colNum + 1
Loop
End Sub
Public Function alphaCon(aNumber As Integer) As String
' Fixed version 27/10/2011
Dim letterArray As String
Dim iterations As Integer
letterArray = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
If aNumber <= 26 Then
alphaCon = (Mid$(letterArray, aNumber, 1))
Else
If aNumber Mod 26 = 0 Then
iterations = Int(aNumber / 26)
alphaCon = (Mid$(letterArray, iterations - 1, 1)) & (Mid$(letterArray, 26, 1))
Else
'we deliberately round down using 'Int' as anything with decimal places is not a full iteration.
iterations = Int(aNumber / 26)
alphaCon = (Mid$(letterArray, iterations, 1)) & (Mid$(letterArray, (aNumber - (26 * iterations)), 1))
End If
End If
End Function
I need to loop over all rows (except my header rows) and merge all cells with the same value in the same column. Before I do this I already made sure, that the column is sorted.
So I have some setup like this.
a b c d e
1 x x x x
2 x x x x
2 x x x x
2 x x x x
3 x x x x
3 x x x x
And need this
a b c d e
1 x x x x
2 x x x x
x x x x
x x x x
3 x x x x
x x x x
With my code I achieved to merge two equal cells. Instead I need to merge all equal cells.
Dim i As Long
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
If Cells(i, 1) <> "" Then
If Cells(i, 1) = Cells(i - 1, 1) Then
Range(Cells(i, 1), Cells(i - 1, 1)).Merge
End If
End If
Next i
This method does not use merged cells, but achieves the same visual effect:
Say we start with:
Running this macro:
Sub HideDups()
Dim N As Long, i As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 3 Step -1
With Cells(i, 1)
If .Value = Cells(i - 1, 1).Value Then
.Font.ColorIndex = 2
End If
End With
Next i
End Sub
will produce this result:
NOTE:
No cells are merged. This visual effect is the same because consecutive duplicates in the same column are "hidden" by having the colour of the font be the same as the colour of the cell background.
I know this is an old thread, but I needed something similar. Here's what I came up with.
Sub MergeLikeCells()
Dim varTestVal As Variant
Dim intRowCount As Integer
Dim intAdjustment As Integer
ActiveSheet.Range("A1").Select
'Find like values in column A - Merge and Center Cells
While Selection.Offset(1, 0).Value <> ""
'If instead you have blanks in the column, change the prev statement to While Selection.Offset(1, 0).Value <> "." and add "." to the last 2 rows of the data
intRowCount = 1
varTestVal = Selection.Value
While Selection.Offset(1, 0).Value = varTestVal
intRowCount = intRowCount + 1
Selection.Offset(1, 0).Select
Selection.ClearContents
Wend
intAdjustment = (intRowCount * -1) + 1
Selection.Offset(intAdjustment, 0).Select
Selection.Resize(intRowCount, 1).Select
With Selection
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Selection.Offset(1, 0).Resize(1, 1).Select
Wend
End Sub
My solution as below, have a good day!
Sub MergeSameValue()
Application.DisplayAlerts = False
Dim LastRow As Integer
Dim StartRow As Integer
StartRow = 2
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Dim StartMerge As Integer
StartMerge = StartRow
For i = StartRow + 1 To LastRow
If Cells(i, 1) <> "" Then
If Cells(i, 1) <> Cells(i - 1, 1) Then
Range(Cells(i - 1, 1), Cells(StartMerge, 1)).Merge
StartMerge = i
End If
End If
Next i
End Sub