I want to highlight and count the number of duplicates in a single concatenated column.
I have it as two separate subs right now and there really isn't much more to say, this isn't that hard of a problem I'm confident of that but I have been working on it for days with absolutely no progress. It has to be done in a VBA and it cannot highlight blank cells in the column. The concatenations are done through a formula in the workbook. Please help me, I m dying,
Sub Duplicate_Check()
Dim ws As Worksheet
Set ws = Sheet1
Worksheets("Master Checklist").Activate
Columns("H:H").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Interior
.ColorIndex = 40
.TintAndShade = 0
End With
'Sheet2.Range(“L2").Value = Application.WorksheetFunction.Countif(Columns("H:H")), cell.Font.Color = "-16383844")
'Range(“B10?).Value = Application.WorksheetFunction.Countif(Range(“A2:A8?), “>” & 50
End Sub
Sub CountDupes()
Dim countofDupes As Long
Dim rng As Range
Dim myCell As Range
countofDupes = 0
Set rng = Range("H2").End(xlDown)
For Each myCell In rng
If myCell.Interior.ColorIndex = 40 Then
countofDupes = countofDupes + 1
Debug.Print countofDupes
End If
Next myCell
End Sub
I don't encounter any error messages but if I Debug.Print countofDupes I get nothing returned, which it obviously not what I want. Any advice?
Related
sub copycolmns() **code for copying columns data along with header in another sheet name paste sheet**
Sheets("copysheet1").Columns(11).Copy Destination:=Sheets("paste").Columns(1)
Sheets("copysheet2").Range("A1:A20").Copy
Sheets("paste").Range("B1").PasteSpecial xlPastevalues
End Sub
Sub reconncilirecords() ** this function to reconcile records and color them green if matching**
Dim col1 As Range, col2 as Range,Prod1 as String, Prod2 as String
Set col1 = Sheets("paste").Columns("A")
Set col2 = Sheets("Paste").Columns("B")
lr = Sheets("paste").Columns("A:B").SpecialCells(xlCellTypeLastCell).Row
For r = 2 to lr
Prod1 = Cells(r, col1.Column).Value
Prod2 = Cells(r, col2.Column).Value
If Prod1 = Prod2 Then
Cells(r, col1.Column).Interior.Color = vbGreen
Cells(r, col2.Column).Interior.Color = vbGreen
Else
Cells(r, col1.Column).Interior.Color = vbRed
Cells(r, col2.Column).Interior.Color = vbRed
End If
Next r
End Sub
Sub Result() **function to display if marching or not matching with message box**
Dim wj as Wrokbook
Dim ws_data as worksheet
Dim rng_data as Range
Set wj = Activeworkbook
Set ws_data = ws.Sheets("paste")
Dim last_row as Long
last_row = ws_data.Cells(Rows.Count, "A").End(xlup).Row
Set rng_data = Range("A2:A" & last_row)
If rng_data.Interior.Color = RGB(0,255,0) then
Msgbox" details verfd and matching"
Else
Msbxo "Mismatch found"
End If
End Sub
is there any way to speed up this process as whenever i run reconcile data 2nd sub function macro is getting hanged. Is there any other way to dynamically copy from sheet1 and sheet2 and recocnile the data and apply message box to check for last row.
Building on my comment; this is a mock-up, so untested... should give an idea:
destWS.Columns(1).value = sourceWS1.columns(2).value
destWS.Columns(2).value = sourceWS2.columns(2).value
With destWS.Range("A1:B" & destLastRow)
.FormatConditions.Add Type:=xlExpression, Formula1:="=$A1=$B1"
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
With .Interior
.Color = vbRed
End With
End With
End With
You will most likely want to use exact ranges, not columns, as it slows things down... a lot.
My code uses conditional formatting to look at the row values in Column A "Order ID", compares them, and then formats the cell if the row values are different. Instead of formatting the cell, how do I format the entire row based off of consecutive row values in Column A "Order ID" being different?
Said differently - if the value in Column A "Order ID" is different from the previous value in Column A "Order ID", I want to format the entire row that is different. My data is variable everyday so I need to use VBA!
Here is the output of my current code:
This is the desired outcome:
Here is the code
Sub Fulfillment()
'
' Fulfillment Macro
' Format the order number in column A as plum
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=MOD(SUM((A$2:A2<>A$1:A1)*1),2)=0"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font.Color = RGB(0, 0, 0)
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = RGB(221, 160, 221)
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Thank you! I do not necessarily need a conditional formatting solution, just a VBA solution that works dynamically.
A Different Flavor of Banded Rows
Option Explicit
Sub Fulfillment()
'
' Fulfillment Macro
' Format the order number in column A as plum
Const CriteriaColumn As Long = 1
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1") ' adjust
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
Set rg = rg.Resize(rg.Rows.Count - 2).Offset(2) ' exclude first two rows
Application.ScreenUpdating = False
rg.Interior.Color = xlNone
Dim Col As Long: Col = 1
Dim cell As Range
Dim r As Long
For Each cell In rg.Columns(CriteriaColumn).Cells
r = r + 1
If cell.Value <> cell.Offset(-1).Value Then Col = Col Mod 2 + 1
If Col = 2 Then rg.Rows(r).Interior.Color = RGB(221, 160, 221)
Next cell
Application.ScreenUpdating = True
MsgBox "Fulfillment accomplished.", vbInformation
End Sub
This is really simple but I'm new to VBA.
I want to format cells in column J and K (haven't gotten to K yet) with a grey fill and border around if cells in column B is not empty. I want to do this in every worksheet in the workbook.
Sub forEachWs()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Call Format_ForecastingTemplate(ws)
Next
End Sub
Sub Format_ForecastingTemplate(ws As Worksheet)
Dim cell As Range
Dim N As Long
Dim i As Long
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To N
If cell <> "" Then
With ActiveSheet.Range(Cells("J"), cell.Row)
.ThemeColor = xlThemeColorDark1
.BorderAround LineStyle:=xlContinuous
End With
End If
Next
End Sub
The line that is giving me an error is If cell <> "" Then. I think it's because I'm not referencing the cell variable in column B?
Error is: Object variable or With block variable not set
Like this:
I changed it to a single macro and made changes to your original code
Sub Format_ForecastingTemplate()
Dim cell As Range
Dim N As Long
Dim i As Long
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To N
'Looks at B to check if empty
If ws.Cells(i, 2).Value <> "" Then
'changes cells J to color and border
ws.Cells(i, 10).Borders.LineStyle = xlContinuous
ws.Cells(i, 10).Interior.ThemeColor = xlThemeColorDark1
ws.Cells(i, 10).Interior.TintAndShade = -0.25
End If
Next i
Next ws
End Sub
You can either change the column number or add new lines for column K
Hope this helps and please be kind and leave feedback. :)
the yellow highighted is where the data is entered lets say cell b2 is data entry.. and i2 to AD2 are the cells in which formulas are suppose to be set.
i need a vba code which identifies b2 = any amount/symbol if its true, I2 to ad2 should insert this if formula [[IF($I$1=D2,G2,"")]
This should be applied in all the rows
Please place this in your worksheet's module.
It checks, whether cell B2 is changed and contains something, and then places the formula in whole range, starting at I2:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RelevantArea As Range
Dim lastRow As Long
Set RelevantArea = Intersect(Target, Me.Range("B2"))
If Not RelevantArea Is Nothing Then
If Len(Target.Value2) > 0 Then
' find the last used row, e. g. in column 9:
lastRow = Me.Cells(Me.Rows.Count, 9).End(xlUp).Row
Application.EnableEvents = False
Me.Range("I2:AD" & lastRow).Formula = "=IF(I$1=$D2,$G2,"""")"
Application.EnableEvents = True
End If
End If
End Sub
The formula is inserted into the range like you would get it, if you copy the formula of the first cell (here: I2) to the rest of the range. I changed the formula a little, assuming you wanted it like that.
By following you get it for the changed row only, i. e. if you paste into e. g. B5:B9, it works for rows 5 to 9.
You can use the A1- or R1C1-notation to adapt the formula to your needs.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MonitoredArea As Range
Dim CurrentRow As Long
Dim CurrentCell As Range
Set MonitoredArea = Intersect(Target, Me.Range("B:B"))
If Not MonitoredArea Is Nothing Then
For Each CurrentCell In MonitoredArea.Cells
If Len(CurrentCell.Value2) > 0 Then
CurrentRow = CurrentCell.Row
Application.EnableEvents = False
With Me.Range(Me.Cells(CurrentRow, "I"), Me.Cells(CurrentRow, "AD"))
.Formula = "=IF(I$1=$D" & CurrentRow & ",$G" & CurrentRow & ","""")"
'.FormulaR1C1 = "=IF(R1C=RC4,RC7,"""")"
Dim i As Integer
For i = xlEdgeLeft To xlInsideHorizontal ' all borders
With .Borders(i)
.LineStyle = xlContinuous
.Weight = xlThin
.Color = RGB(0, 0, 0)
.TintAndShade = 0
End With
Next i
End With
Application.EnableEvents = True
End If
Next CurrentCell
End If
End Sub
I'm using this code below to convert formula to cells, which works fine in a single sheet. But the problem is when I need to convert all selected cells which are in different sheets to their value, this code doesn't do it.
This is how I am selecting the cells in Excel:
first I select the cells in one sheet, than I go down to the tabs right-click and select specific sheets, which in Excel selects the corresponding cells in every selected sheet.
So any tips on how I can change this code to make it work across different sheets?
Sub formulaToValues()
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each cel In Selection.Cells
cel.Value = cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
End If
End Sub
You should be able to just grab the address of the selection, then add that to each worksheet's range
Sub formulaToValues()
Dim celAddr As String
celAddr = Selection.Address
Dim ws As Worksheet
For Each ws In ActiveWindow.SelectedSheets
With ws.Range(celAddr)
.Value = .Value
.Interior.ColorIndex = 0
.Font.Color = vbBlack
End With
Next ws
End Sub
You are attempting to write to a 3D cell collection. An interesting problem i haven't seen before. I gave it a shot.
The below code works for me. I have simply added an extra loop to search through any other sheets. Note: it is good practice to always declare your variables.
Answer1: This cycles through every sheet in the workbook
Sub formulaToValues()
Dim cel As Range
Dim ws As Worksheet
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each ws In ThisWorkbook.Worksheets
For Each cel In Selection.Cells
ws.Range(cel.Address).Value = 2 'cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
Next ws
End If
End Sub
Answer2: With this one it only goes throug the selected sheets
Sub formulaToValues()
Dim cel As Range
Dim ws As Worksheet
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each ws In ThisWorkbook.Windows(1).SelectedSheets
For Each cel In Selection.Cells
ws.Range(cel.Address).Value = 2 'cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
Next ws
End If
End Sub
Thanks alot guys, this got answered pretty quickly.
I am placing my macros in personal so I ended if with this
Sub formulaToValues3()
Dim cel As Range
Dim ws As Worksheet
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each ws In ActiveWorkbook.Windows(1).SelectedSheets
For Each cel In Selection.Cells
ws.Range(cel.Address).Value = ws.Range(cel.Address).Value 'cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
Next ws
End If
End Sub