Excel VBA Code to merge similar adjacent cells - excel

I'd like to merge identical adjacent cells within a column. Some online examples loop through the column and merge every time the cell below matches, and I'd like to avoid that. Here's my current broken attempt that spits out run-time error 5.
Sub Merge2()
Application.ScreenUpdating = False
Dim rng1 As Range
Dim rng2 As Range
Dim certaincell As Range
Dim LastRow As Long
LastRow = 0
LastRow = Cells(Rows.Count, 35).End(xlUp).Row
Set rng1 = Range(Cells(2, 35), Cells(LastRow, 35))
CheckUnder:
For Each certaincell In rng1
Set rng2 = Union(rng2, certaincell) 'Add the checking cell to the range
If certaincell.Value = certaincell.Offset(1, 0).Value Then 'if the cell is the same as the cell under
'move on to next cell
Else
rng2.Merge 'merge similar cells above
Set rng2 = Nothing
End If
Next
Application.ScreenUpdating = True
End Sub

The variable rng2 is initially set to Nothing. So, adjust your code as follows:
For Each certaincell In rng1
If rng2 Is Nothing Then
Set rng2 = certaincell
End If
Set rng2 = Union(rng2, certaincell) 'Add the checking cell to the range
If certaincell.Value = certaincell.Offset(1, 0).Value Then
Else
rng2.Merge 'merge similar cells above
Set rng2 = Nothing
End If
Next
The if statement will check if the rng2 is nothing and if so, it will assign the currently checked certaincell to the variable.
Also, merging cells with data will pop up some error dialogs. This can be avoided by using Application.DisplayAlerts = False.
Make sure to turn it on using Application.DisplayAlerts = True at the end.

Related

Compare numbers between two columns and match the colours

I am struggling to find any info on the internet to make this work, please help me out.
I would like a function to do the following (summarized below)
As you can see column A3:A7 has a number in each cell and a colour associated with that specific number.
I would like the code to scan through A3:A7 and match the numbers in C3:C7 with the colour that's already applied. (See below for detailed explanation)
For instance, A3 has a value of 1 and is yellow, I would like the code to scan through all numbers in Column C (C3:C7) and identify that C6 is also 1, therefore it will apply yellow to C6.
Initial:
Final:
Also can this be done across two different Sheets.For example lets say A3:A7 is on Sheet1 and I want to find matches in C3:C7 in Sheet2
Sub ColourCells()
Dim Rng1 As Range, Rng2 As Range, Rng2Item As Range
Dim Rng1LRow As Long, Rng2LRow As Long
Dim Rng1Match As Variant
With Worksheets("Sheet1")
Rng2LRow = .Cells(.Rows.Count, 3).End(xlUp).Row
Set Rng2 = .Range("C3:C" & Rng2LRow)
End With
With Worksheets("Sheet2")
Rng1LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Rng1 = .Range("A3:A" & Rng1LRow)
End With
For Each Rng2Item In Rng2
With Rng2Item
Rng1Match = Application.Match(.Value, Rng1, 0)
If IsError(Rng1Match) Then
GoTo NextItem
Else
.Interior.Color = Application.Index(Rng1, Rng1Match, 0).Interior.Color
End If
End With
NextItem:
Next Rng2Item
End Sub
Sub test()
Dim rng1 As Range, rng2 As Range, rng As Range
Set rng1 = Range("A3:A7")
Set rng2 = Range("C3:C7")
For Each rng In rng2
With Application.WorksheetFunction
If .CountIf(rng1, rng.Value) > 0 Then rng.Interior.Color = .Index(rng1, .Match(rng.Value, rng1, 0), 1).Interior.Color
End With
Next rng
Set rng1 = Nothing
Set rng2 = Nothing
End Sub

Vba Code to Delete data based on a drop box choice

I have a sheet that has a List box when that is selected codes appear. If a code is selected, excel copies the data from a worksheet (with the same code) into a quotation sheet.
If I make a change and select another code in the same list box, I need excel to go and find the old data and delete it in the Quotation sheet.
Public Sub delete_selected_rows()
Dim rng1 As Range, rng2 As Range, rngToDel As Range, c As Range
Dim lastRow As Long
With Worksheets("Q")
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
Set rng1 = .Range("B1:B" & lastRow)
End With
Set rng2 = Worksheets("SO").Range("D35")
For Each c In rng1
If Not IsError(Application.Match(c.Value, rng2, 0)) Then
'if value from rng1 is found in rng2 then remember this cell for deleting
If rngToDel Is Nothing Then
Set rngToDel = c
Else
Set rngToDel = Union(rngToDel, c)
End If
End If
Next c
If Not rngToDel Is Nothing Then rngToDel.CurrentRegion.Delete
End Sub
How can I get CurrentRegion to count an extra 30 rows the delete?
VBA's ISERROR won't catch the error caused by a failed MATCH worksheet function. You need to construct that part differently.
Public Sub delete_selected_rows()
Dim rng1 As Range, rng2 As Range, rngToDel As Range, c As Range
Dim lastRow As Long
Dim R As Long
With Worksheets("Q")
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
Set rng1 = .Range("B1:B" & lastRow)
End With
Set rng2 = Worksheets("SO").Range("D35")
For Each c In rng1
On Error Resume Next
R = 0
R = WorksheetFunction.Match(c.Value, rng2, 0)
On Error GoTo 0
If R Then
'if value from rng1 is found in rng2 then remember this cell for deleting
' R is the row number in rng2 where a match was found
' since rng2 is a single cell, R would always be 1, if found
' If rng2 = D35 MATCH be an overkill. Why not simply compare?
Else
If rngToDel Is Nothing Then
Set rngToDel = c
Else
Set rngToDel = Union(rngToDel, c)
End If
End If
Next c
If Not rngToDel Is Nothing Then rngToDel.CurrentRegion.Delete
End Sub
Please observe my comments about rng2. Could there be some mistake? What does SO.D35 contain? If it contains a string of values one of which might be the one you look for MATCH is the wrong function to use.
It seems that you intend to put all items to be deleted on a spike and delete them in one go at the end. I'm not sure that is possible, and it's getting late for me. The more common approach would be to delete one row at a time, as you find them, because once you delete a row all row numbers below that row will change. You can run the entire code with ScreenUpdating turned off and set Application.ScreenUpdating = True after all the deleting has been done.

VBA Excel: Prevent Excel to change data as date after changing all cells to uppercase

I have the following code to capitalize all data in two specified ranges and then run some comparing code.
The issue is once it runs the capitalize code cells that contain something like 1-2 gets changed to 2-Jan. I cannot apply .NumberFormat = "#" to the entire worksheet or that specific column because I am making the sheet dynamic and this data won't always be in the same column. Anyone know how to take care of this problem?
Dim rangeToUse As Range, singleArea As Range, cell1 As Range, cell2 As Range, rng As Range, rng2 As Range
Dim I As Integer, J As Integer
'Set two range selections
Set rng = Application.InputBox("Select First Range", "Obtain 1st Range Object", Type:=8)
Set rng2 = Application.InputBox("Select Second Range", "Obtain 2nd Range Object", Type:=8)
Set MultiRange = Union(rng, rng2)
MultiRange.Select
Set rangeToUse = Selection
Cells.Interior.ColorIndex = 0
Cells.Borders.LineStyle = xlNone
'Capitalizes all cells in selected range
'Turn off screen updating to increase performance
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Worksheets("Phase 3 xwire").Range(rangeToUse).NumberFormat = "#"
'Convert all constants and text values to proper case
For Each LCell In Cells.SpecialCells(xlConstants, xlTextValues)
LCell.Formula = UCase(LCell.Formula)
Calculate
Next
If Selection.Areas.Count <= 1 Then
MsgBox "Please select more than one area."
Else
rangeToUse.Interior.ColorIndex = 0
For Each singleArea In rangeToUse.Areas
singleArea.BorderAround ColorIndex:=1, Weight:=xlMedium
Next singleArea
'Areas.count - 1 will avoid trying to compare
' Area(count) to the non-existent area(count+1)
For I = 1 To rangeToUse.Areas.Count - 1
For Each cell1 In rangeToUse.Areas(I)
'I+1 gets you the NEXT area
Set cell2 = rangeToUse.Areas(I + 1).Cells(cell1.Row - 1, cell1.Column - 1)
If IsEmpty(cell2.Value) Then
GoTo Done
Else
If cell1.Value <> cell2.Value Then
cell1.Interior.ColorIndex = 38
cell2.Interior.ColorIndex = 38
End If
End If
Next cell1
Next I
Done:
End If
'Turn screen updating back on
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
If you are keeping the Input Boxes you could add this line of code after your MultiRange.Select command
Selection.NumberFormat = "#"

Highlighting duplicates based on data within the same column

I'm trying to create a macro that searches the B column to find duplicates of the same string, and then highlights said duplicates from columns A to I
I've managed to create something that highlights the correct cells but does not seem to be able to find the duplicates. Not entirely sure where I've gone wrong but I think it could be because I'm adapting a former macro that looked across two sheets
Code:
Sub Duplicate()
Dim rng1 As Range, rng2 As Range, rng3 As Range, i As Long, j As Long
Dim w1 As Worksheet
Set w1 = Worksheets("Sheet1")
For i = 1 To w1.Range("B" & Rows.Count).End(xlUp).Row
Set rng1 = w1.Range("B" & i)
For j = 1 To w1.Range("B" & Rows.Count).End(xlUp).Row
Set rng2 = w1.Range("B" & j)
Set rng3 = w1.Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 9))
If StrComp(Trim(rng1.Text), Trim(rng2.Text), vbTextCompare) = 0 Then
rng3.Interior.Color = RGB(168, 188, 255)
End If
Set rng2 = Nothing
Next j
Set rng1 = Nothing
Next i
End Sub
At the moment I see one problem, you are referring to Activecell, However you never activate or select any cell nor range. This makes the color change on a cell that you have selected when running the macro and no other. If you replace activecell.row with variable i the macro should be working fine.
Does this have to be within VBA? The conditional formatting feature in Excel can do this without having to rely on a macro. This should also refresh faster than running the VBA. For this you have to rely on relative references within the conditional formatting, which are relative to the activecell at the time you set up the rule.
Select your data from A:I
Conditional formatting> new rule
Select 'use a formula to determine which cells to format'
Use the formula =COUNTIF($B$1:$B$6,$B1)>1, replacing the first variable with your entire range in column B. The single dollar sign on reference $B1 is very important as it tells it to check column B regardless of which column the formatting is being applied to.
You are always setting rng3 to the same cells, because you never change the active cell. Also, you don't really need to have an extra range because you are already looping through the cells.
Sub Duplicate()
Dim rng1 As Range, rng2 As Range, rng3 As Range, i As Long, j As Long
Dim w1 As Worksheet
Set w1 = Worksheets("Sheet1")
For i = 1 To w1.Range("B" & Rows.Count).End(xlUp).Row
Set rng1 = w1.Range("B" & i)
For j = 1 To w1.Range("B" & Rows.Count).End(xlUp).Row
If j <> i Then
Set rng2 = w1.Range("B" & j)
If StrComp(Trim(rng1.Text), Trim(rng2.Text), vbTextCompare) = 0 Then
rng1.Interior.Color = RGB(168, 188, 255)
rng2.Interior.Color = RGB(168, 188, 255)
End If
Set rng2 = Nothing
End If
Next j
Set rng1 = Nothing
Next i
End Sub

Find a value, copy an offset but only to a point

In various places in column E of spreadsheet "Review" I have variables that start with the word "Sustainability:" (e.g., Sustainability: a, Sustainability:B"). Each time it finds one. I want it to copy the cell that is in the same row but two columns to the right. Then I want it to paste into a different sheet (SPSE Tran), starting at B63. Each time it pastes, the destination needs to offset by 1 row so it can paste down until it finds no more "Sustainability:". The code below is a start to this but I am stuck.
The second thing I need it to do (which I don't even know where to start) is to only iterate doing this until it finds a row that says "ONLY FOR TRANSITIONS". This leads into a new section that also includes "Sustainability:" but I don't want it to copy from there.
Thank you!
Sub SubmitData()
Dim RngA As Range
Dim FirstAd As String
Dim DestAd As Range
With Sheets("Review").Range("E:E")
Set RngA = .Find(What:="Sustainability:", lookat:=xlPart)
Set DestAd = Range("B63")
If Not RngA Is Nothing Then
FirstAd = RngA.Address
Do
Range(Cell, Cell.Offset(0, 2)).Copy _
Destination:=Sheets("SPSE Tran").Range(DestAd)
Set RngA = .FindNext(RngA)
Set DestAd = DestAd.Offset(0, 1)
Loop While Not RngA Is Nothing And RngA.Address <> FirstAd
End If
End With
End Sub
Here's your code revamped to use a filter instead of a find loop, and then it gets all the results and copies them to the destination at once:
Sub SubmitData()
Dim ws As Worksheet
Dim rngDest As Range
Dim rngStop As Range
With Sheets("SPSE Tran")
Set rngDest = .Cells(Rows.Count, "B").End(xlUp)
If rngDest.Row < 63 Then Set rngDest = .Range("B63")
End With
Set ws = Sheets("Review")
Set rngStop = ws.Columns("A").Find("ONLY FOR TRANSITIONS", , xlValues, xlPart)
With ws.Range("E1:E" & rngStop.Row)
.AutoFilter 1, "Sustainability:*"
.Offset(1, 2).Copy rngDest
.AutoFilter
End With
End Sub
How about (untested):
RngB = where you find "ONLY FOR TRANSITIONS"
RngBRow = RngB.Row
then change your Loop While .. to
Loop While Not RngA Is Nothing And RngA.Address <> FirstAd And RngA.Row < RngBRow

Resources