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.
Related
Hi I'm trying to use either VBA or conditional formatting for this but it doesn't work the way I want it to :/
Column B is a list of values that are keyed in by different people one at a time, column C is the status of the person.
What I'm trying to achieve: ONLY when column C is "OUT", the value in the adjacent cell (in column B) is shaded and all the same values of that cell is shaded as well.
I can shade the column B cell given "OUT" in column C but I can't get all the same values before that to be shaded as well.
There are 3 possible status: NEW, AFTERNOON, OUT
Anyone have any ideas please? I attached a photo I hope it explains abit clearer
Is there a way to highlight more than 2 cells? If I have 3 of same value, only the last 2 duplicates will be highlighted – geravie498 5 hours ago
In such a case you only need one rule.
Let's assume the data is in B1:C10. Adapt the formula accordingly.
Match all the value of B1 in the range below where $B$1:$B$10=$B1 and $C$1:$C$10="OUT"
RULE
=INDEX($B$1:$B$10,MATCH(1,($B$1:$B$10=$B1)*($C$1:$C$10="OUT"),0))
I really like #Siddharth's but for completeness here's a way you can do it in VBA:
Paste this code into your sheet's module
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lCodesCol As Long: lCodesCol = 3
If Target.Column <> lCodesCol And Target.Column <> lCodesCol - 1 Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim vData As Variant
Dim i As Long, j As Long
Dim lFirstRow As Long: lFirstRow = 2
Dim lLastRow As Long
Dim rngToHighlight As Range
With Me
lLastRow = WorksheetFunction.Max(lFirstRow, _
.Cells(.Rows.Count, lCodesCol).End(xlUp).Row, _
.Cells(.Rows.Count, lCodesCol - 1).End(xlUp).Row)
vData = .Range(.Cells(1, lCodesCol - 1), .Cells(lLastRow, lCodesCol)).Value
For i = lFirstRow To lLastRow
If vData(i, 2) = "OUT" And vData(i, 1) <> "" Then
For j = lFirstRow To lLastRow
If vData(i, 1) = vData(j, 1) Then
If rngToHighlight Is Nothing Then
Set rngToHighlight = .Cells(j, lCodesCol - 1)
Else
Set rngToHighlight = Union(.Cells(j, lCodesCol - 1), rngToHighlight)
End If
End If
Next j
End If
Next i
With .Cells(lFirstRow, lCodesCol - 1).Resize(lLastRow, 1).Interior
.Pattern = xlNone
End With
If Not rngToHighlight Is Nothing Then
With rngToHighlight.Interior
.Pattern = xlSolid
.Color = RGB(200, 200, 200)
End With
End If
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Please note that conditional formatting is much faster than any vba code you can write and the differences get more significat as your data grows.
I need to be able to compare every cell in 2 worksheets but the data won't always be in the same row as new data is added and exported constantly.
Range on both sheets would be fairly large, so for now I have limited it to A1:AS150. Any instance where a match cannot be found I'd like to highlight the cell.
I have found this, which looks close to what I need but doesn't work (obviously, I have added the Else code in my working example).
Sub test()
Dim varSheetA As Variant
Dim varSheetB As Variant
Dim strRangeToCheck As String
Dim iRow As Long
Dim iCol As Long
strRangeToCheck = "A1:AS150"
' If you know the data will only be in a smaller range, reduce the size of the ranges above.
Debug.Print Now
varSheetA = Worksheets("Sheet1").Range(strRangeToCheck)
varSheetB = Worksheets("Sheet2").Range(strRangeToCheck) ' or whatever your other sheet is.
Debug.Print Now
For iRow = LBound(varSheetA, 1) To UBound(varSheetA, 1)
For iCol = LBound(varSheetA, 2) To UBound(varSheetA, 2)
If varSheetA(iRow, iCol) = varSheetB(iRow, iCol) Then
' Cells are identical.
' Do nothing.
Else
' Cells are different.
' Code goes here for whatever it is you want to do.
End If
Next iCol
Next iRow
To answer 'Foxfire And Burns And Burns' Questions:
Checks: Does Sheet1.Cell$.Value exist in sheet2 but for every cell in the range on both sheets.
Sheet1
A
B
C
Paul
999
ABC111
John
888
ABC222
Harry
777
ABC333
Tom
666
ABC444
Sheet2
A
B
C
Tom
666
ABC444
John
888
ABC222
Harry
777
ABC333
So in these examples:
Search Sheet1.A1 in Sheet 2, IF = Match Then nothing ELSE Highlight Red. Then A2, A3 etc, Then B1, B2 etc, Then C1, C2 etc...you get the gist.
You mention in your VBA code that something will need to be done, but in your example your just mean that a cell will be highlighted.
This is already covered by Excel's conditional formatting feature. You can be conditional formatting on a formula (in your case you might use a Match() function).
I would advise you to start working with a =Match() formula, in order to learn how this works (you might use =MATCH(A1,$B$1:$B$2,0) as an example, the dollarsigns are used for indicating that the lookup values are not to change), do it on different sheets and then try to get conditional formatting working, first basically and then based on your formula.
Sub test()
Dim varSheetA As Worksheet
Dim varSheetB As Worksheet
Dim i As Long
Dim LR As Long
Set varSheetA = ThisWorkbook.Worksheets("Sheet1")
Set varSheetB = ThisWorkbook.Worksheets("Sheet2")
LR = varSheetA.Range("A" & varSheetA.Rows.Count).End(xlUp).Row
For i = 1 To LR 'we start at first row of sheet 1
If Application.WorksheetFunction.CountIf(varSheetB.Range("A:A"), varSheetA.Range("A" & i).Value) = 0 Then varSheetA.Range("A" & i).Interior.Color = vbRed
Next i
'clean variables
Set varSheetA = Nothing
Set varSheetB = Nothing
End Sub
The code will count each single cell value from column A from Sheet 1 and will check if it exists somewhere in column A in Sheet 2. If not, then highligh in red.
Output after executing code with the data example you've posted:
UPDATE": I made a fakedataset. Notice row Captain America. Values from columns A and C are same in both sheets, but different on column B
Sub test()
Dim varSheetA As Worksheet
Dim varSheetB As Worksheet
Dim i As Long
Dim LR As Long
Dim MyPos As Long
Set varSheetA = ThisWorkbook.Worksheets("Sheet1")
Set varSheetB = ThisWorkbook.Worksheets("Sheet2")
LR = varSheetA.Range("A" & varSheetA.Rows.Count).End(xlUp).Row
For i = 1 To LR 'we start at first row of sheet 1
If Application.WorksheetFunction.CountIf(varSheetB.Range("C:C"), varSheetA.Range("C" & i).Value) > 0 Then
'Match found on Column C. Check A and B
MyPos = Application.WorksheetFunction.Match(varSheetA.Range("C" & i).Value, varSheetB.Range("C:C"), 0)
If varSheetA.Range("A" & i).Value <> varSheetB.Range("A" & MyPost.Value Then varSheetA.Range("A" & i).Interior.Color = vbRed
If varSheetA.Range("B" & i).Value <> varSheetB.Range("B" & MyPos).Value Then varSheetA.Range("B" & i).Interior.Color = vbRed
End If
Next i
'clean variables
Set varSheetA = Nothing
Set varSheetB = Nothing
End Sub
Output:
That cell has been highlighet because is different.
Please, note this code will work only if all values in column C are unique.
Here is my code:
Option Explicit
Private Const SHEET_1 As String = "Sheet1"
Private Const SHEET_2 As String = "Sheet2"
Private Const FIRST_CELL As String = "A1"
Private Const MAX_ROWS As Long = 1048576
Private Const MAX_COLUMNS As Long = 16384
Private varSheetA As Worksheet
Private varSheetB As Worksheet
Private last_row As Long
Private last_column As Long
Private sheet1_row As Long
Private sheet1_column As Long
Private sheet2_row As Long
Private row_match As Boolean
Public Sub CompareTables()
Set varSheetA = ThisWorkbook.Worksheets(SHEET_1)
Set varSheetB = ThisWorkbook.Worksheets(SHEET_2)
'Gets the real Table size
For sheet1_row = 1 To MAX_ROWS - 1
If varSheetA.Range(FIRST_CELL).Offset(sheet1_row, 0).Value = vbNullString _
And varSheetB.Range(FIRST_CELL).Offset(sheet1_row, 0).Value = vbNullString Then
last_row = sheet1_row
Exit For
End If
Next
For sheet1_column = 1 To MAX_ROWS - 1
If varSheetA.Range(FIRST_CELL).Offset(0, sheet1_column).Value = vbNullString _
And varSheetB.Range(FIRST_CELL).Offset(0, sheet1_column).Value = vbNullString Then
last_column = sheet1_column
Exit For
End If
Next
'Sets color RED by default on both Tables
Call SetTextRed(varSheetA.Range(FIRST_CELL).Resize(last_row, last_column))
Call SetTextRed(varSheetB.Range(FIRST_CELL).Resize(last_row, last_column))
'Sweeps all existing ROWS on Sheet1
For sheet1_row = 1 To last_row
'Sweeps all existing ROWS on Sheet2
For sheet2_row = 1 To last_row
row_match = True
'Sweeps all existing COLUMNS on Sheet1 and Sheet2
For sheet1_column = 1 To last_column
If varSheetA.Range(FIRST_CELL).Offset(sheet1_row - 1, sheet1_column - 1).Value _
<> varSheetB.Range(FIRST_CELL).Offset(sheet2_row - 1, sheet1_column - 1).Value Then
row_match = False
Exit For
End If
Next
If row_match Then Exit For 'Found and entire match, no need to search more
Next
'Formats as Grren whenever is a Match
If row_match Then
Call SetTextGreen(varSheetA.Range(FIRST_CELL).Offset(sheet1_row - 1, 0).Resize(1, last_column))
Call SetTextGreen(varSheetB.Range(FIRST_CELL).Offset(sheet2_row - 1, 0).Resize(1, last_column))
End If
Next
End Sub
'Sub Function that sets entire row text as RED
Private Sub SetTextRed(ByVal entireRow As Range)
With entireRow.Font
.Color = RGB(255, 0, 0)
.TintAndShade = 0
End With
End Sub
'Sub Function that sets entire row text as GREEN
Private Sub SetTextGreen(ByVal entireRow As Range)
With entireRow.Font
.Color = RGB(0, 255, 0)
.TintAndShade = 0
End With
End Sub
I am working on a project in which I am comparing column D with column C of sheet("Backend") and the difference is shown in column E (in %). I'd like to highlight the % difference (column E) in RED color, where the difference is less than -10.00% and greater than 10.00%. Then would like to copy those items from column B corresponding each highlighted cell and paste it in sheet("UPDATER") beneath cell A7.
Attached is the screenshot for your reference
Sub check_date()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wsData As Worksheet, Datasht As Worksheet, lRow As Integer
Set wsData = Sheets("UPDATER")
Set Datasht = Sheets("Backend")
lRow = Datasht.Cells(Rows.Count, 13).End(xlUp).Row
wsData.Range("M8:M" & lRow).Interior.ColorIndex = xlNone
wsData.Range("M8:M" & lRow).FormatConditions.Add Type:=xlExpression, Formula1:="=AND(M8>=EOMONTH(TODAY(),-2)+1,M8<EOMONTH(TODAY(),-1))"
wsData.Range("M8:M" & lRow).FormatConditions(wsData.Range("M8:M" & lRow).FormatConditions.Count).SetFirstPriority
With wsData.Range("M8:M" & lRow).FormatConditions(1).Interior
.Color = RGB(255, 255, 0)
.TintAndShade = 0
End With
wsData.Range("M8:M" & lRow).FormatConditions(1).StopIfTrue = False
Range("M8").Select
End Sub
Here's what I got. It's a bit of a drastic change but I'm hoping this is actually what you're going for.
Sub formatcondition()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wsData As Worksheet, Datasht As Worksheet, lRow As Integer, My_Range As Range, i As Integer, iRow As Integer, cell As Variant, RowNum As Long, lRowUpdater As Long
Set wsData = Sheets("UPDATER")
Set Datasht = Sheets("Backend")
lRow = Datasht.Cells(Rows.Count, 5).End(xlUp).Row
lRowUpdater = wsData.Cells(Rows.Count, 1).End(xlUp).Row
RowNum = 8 'setting the first row in the UPDATER sheet
Datasht.Range("E1:E" & lRow).Interior.ColorIndex = xlNone 'Reset the color before running
wsData.Range("A8:D" & lRowUpdater + 8).ClearContents 'clear your updater sheet. Remove if not needed.
For i = 1 To lRow
On Error GoTo Continue
If Datasht.Range("E" & i).Value < -0.1 Or Datasht.Range("E" & i).Value > 0.1 Then 'If greater than or less than
Datasht.Range("E" & i).Interior.ColorIndex = 6 'Change the color of affected cells if you need that
wsData.Range(wsData.Cells(RowNum, 1), wsData.Cells(RowNum, 4)).Value = _
Datasht.Range(Datasht.Cells(i, 2), Datasht.Cells(i, 5)).Value 'straight copy the values from the cells as it loops rather than using copy/paste
wsData.Range(wsData.Cells(RowNum, 2), wsData.Cells(RowNum, 4)).NumberFormat = "0.00%" 'change the number format of outputted cells to percentages (if needed)
RowNum = RowNum + 1 'move to the next row in the output
End If
Continue:
Resume Nexti
Nexti:
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
EDIT:
For the date to add a year my version would be just adding to what I gave earlier. Instead we now add an AND function to contain the OR, then checking if the YEAR in the cell is the current year. If you're only wanting this year then we can also forgo the IF statement which was checking that if the current month was January it would incorporate December. But if thats not needed then:
=AND(OR(MONTH(NOW())=MONTH(M8),MONTH(NOW())-1=MONTH(M8)),YEAR(M8)=YEAR(NOW()))
Or
=AND(MONTH(M8)>=MONTH(NOW())-1,MONTH(M8)<MONTH(NOW())+1,YEAR(M8)=YEAR(NOW()))
Both the same length and do the same thing just in different way.
I have a pivot table which summarizes three key figures for each individual item in our inventory over a six week time frame.
I want to conditionally format with a color scale the six cells in the "Supplier Inventory DOH" rows for each individual item.
Once those six cells are formatted, I want to copy those colors to the coordinating six cells below in "Total Inventory" without the rules or values which come with the formatting typically.
The purpose of this is to show the Days on Hand risk by color scale, in coordination with the current inventory - think of it as layering formatting on top of the inventory values.
For the formatting process alone I found a similar related discussion referencing this article: Excel conditional colour scale for multiple rows, and I tried using the code it included in the comments. I changed the code and its references to match what I would need- knowing full well that this code is meant just for a blanket drag and drop over all of the data-not for the unique rows themselves. If this code worked I hoped it would be a start at least- however after running it through it didn't do anything. I am wondering if some of this code is incorrect, what kind of code I would add in to only format the rows with the Supplier Inventory DOH description, or if there was a better way to do this?
For the copying formatting piece, I found a related article discussion: How to copy the conditional formatting without copying the rules from a Conditional Formatted cell?, however copy and pasting just the color themselves did not work on my Windows 10 excel version. Is there a way to do this process as well?
Original version of code:
Option Explicit
Sub ApplyConditionalFormatting()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") ' change to your sheet here
Dim rw As Long
Dim rng As Range
For rw = 3 To 8 ' change to your respective rows
With ws
Set rng = .Range(.Cells(rw, "E"), .Cells(rw, "K")) ' change to your respective columns
With rng
.FormatConditions.AddColorScale ColorScaleType:=3
.FormatConditions(.FormatConditions.Count).SetFirstPriority ' now its index is 1, in case there already was cond formatting applied
End With
With rng.FormatConditions(1)
With .ColorScaleCriteria(1)
.Type = xlConditionValueNumber
.Value = 0
.FormatColor.Color = 7039480
End With
With .ColorScaleCriteria(2)
.Type = xlConditionValueFormula
.Value = "='" & ws.Name & "'!$D$" & rw & "*3" ' References column D, change as needed
.FormatColor.Color = 8711167
End With
With .ColorScaleCriteria(3)
.Type = xlConditionValueFormula
.Value = "='" & ws.Name & "'!$D$" & rw & "*5" ' References column D, change as needed
.FormatColor.Color = 8109667
End With
End With
End With
Next rw
End Sub
My version of the code:
Sub CF()
'
' CF Macro
'
' Keyboard Shortcut: Ctrl+f
'
End Sub
Public Sub Formatting()
Option Explicit
Sub ApplyConditionalFormatting()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet2")
Dim rw As Long
Dim rng As Range
For rw = 6 To 1764
With ws
Set rng = .Range(.Cells(rw, "B"), .Cells(rw, "G"))
With rng
.FormatConditions.AddColorScale ColorScaleType:=3
.FormatConditions(.FormatConditions.Count).SetFirstPriority
End With
With rng.FormatConditions(1)
With .ColorScaleCriteria(1)
.Type = xlConditionValueNumber
.Value = 40
.FormatColor.Color = 7039480
End With
With .ColorScaleCriteria(2)
.Type = xlConditionValueFormula
.Value = 70
.FormatColor.Color = 8711167
End With
With .ColorScaleCriteria(3)
.Type = xlConditionValueFormula
.Value = 80
.FormatColor.Color = 8109667
End With
End With
End With
Next rw
End Sub
End Sub
I expect the rows for each individual items DOH to be conditionally formatted based on the rule I need in an automated process that doesn't include going row by row with format painter. Then, to be able to copy those colors to the Total Inventory cells below (without the rules or values) to be able to show the correlation between Days on Hand and what is left in the inventory.
Pivot Table with Rule:
Pivot table with desired formatting:
You can get all relevant cells by PivotSelect,
then add your desired conditional formatting to them,
and use the resulting DisplayFormat.Interior.Color as Interior.Color for your "Total Inventory" cells.
Private Sub ConditionalFormattingforSNCPlanning()
Dim ws As Excel.Worksheet
Dim pt As Excel.PivotTable
Dim fc As Excel.FormatCondition
Dim cs As Excel.ColorScale
Dim strDOH As String, strTotal As String
Dim rngSource As Range, rngDest As Range, rngCell As Range, strDest() As String
Set ws = ActiveWorkbook.Sheets("Sheet2")
Set pt = ws.PivotTables(1)
strDOH = "'SNC PLANNING' 'Supplier Network DOH'"
strTotal = "'SNC PLANNING' 'Total Inventory'"
' Delete all conditional colors and normal interior colors first
With pt.TableRange2
.FormatConditions.Delete
.Interior.ColorIndex = xlNone
.Interior.Pattern = xlNone
End With
' Show all pivottable rows, as otherwise PivotSelect may fail
Dim i As Long
For i = pt.RowFields.Count To 2 Step -1
pt.RowFields(i).ShowDetail = True
Next i
' select all desired rows for conditional formatting
pt.PivotSelect _
Name:=strDOH, _
Mode:=XlPTSelectionMode.xlDataOnly, _
Usestandardname:=True
' if you don't want to delete every conditional format
' by above pt.TableRange2.FormatConditions.Delete
' then use following line here instead
' Selection.FormatConditions.Delete
' Add a new conditional formatting (3-Color Scale)
Set cs = Selection.FormatConditions.AddColorScale(ColorScaleType:=3)
With cs.ColorScaleCriteria(1)
.Type = xlConditionValueNumber
.Value = 40
.FormatColor.Color = RGB(248, 105, 107) ' 7039480
.FormatColor.TintAndShade = 0
End With
With cs.ColorScaleCriteria(2)
.Type = xlConditionValueNumber
.Value = 70
.FormatColor.Color = RGB(255, 235, 132) ' 8711167
.FormatColor.TintAndShade = 0
End With
With cs.ColorScaleCriteria(3)
.Type = xlConditionValueNumber
.Value = 80
.FormatColor.Color = RGB(99, 190, 123) ' 8109667
.FormatColor.TintAndShade = 0
End With
' Get both ranges for later color-copy-code
Set rngSource = Selection
pt.PivotSelect _
Name:=strTotal, _
Mode:=XlPTSelectionMode.xlDataOnly, _
Usestandardname:=True
Set rngDest = Selection
' Exit if both range's cell count not equal
If rngSource.Cells.Count <> rngDest.Cells.Count Then
MsgBox "Sorry, this works only, if cell count is identical"
Exit Sub
End If
' store all addresses of the destination range's cells
ReDim strDest(1 To rngDest.Cells.Count)
i = 1
For Each rngCell In rngDest.Cells
strDest(i) = rngCell.AddressLocal
i = i + 1
Next rngCell
' copy source's DisplayFormat.Interior.Color
' to destination's Interior.Color
' cell by cell
i = 1
For Each rngCell In rngSource.Cells
ws.Range(strDest(i)).Interior.Color = rngCell.DisplayFormat.Interior.Color
i = i + 1
Next rngCell
End Sub
This is a different approach with a loop over the PivotTable.RowRange. When the desired terms are found, the corresponding row of the PivotTable.DataBodyRange is coloured.
The "Source" (e. g. "Supplier Network DOH") is formatted via conditional formatting and the "Destination" (e. g. "Total Inventory") gets the displayed color of the previously conditional formatted row as interior color.
Private Sub ConditionalFormattingforSNCPlanningVersion2()
Dim ws As Excel.Worksheet
Dim pt As Excel.PivotTable
Dim fc As Excel.FormatCondition
Dim cs As Excel.ColorScale
Dim SourceString As String, DestString As String
Dim SourceIsFound As Boolean
Dim SourceRow As Long, DestRow As Long
Dim CellInColumn As Range, CellInRow As Range
Set ws = ActiveWorkbook.ActiveSheet
Set pt = ws.PivotTables(1)
SourceString = "Supplier Network DOH"
DestString = "Total Inventory"
' Delete all conditional colors and normal interior colors first
With pt.TableRange2
.FormatConditions.Delete
.Interior.ColorIndex = xlNone
.Interior.Pattern = xlNone
End With
' Show all pivottable rows
Dim i As Long
For i = pt.RowFields.Count To 2 Step -1
pt.RowFields(i).ShowDetail = True
Next i
' loop all cells in last column of rowrange
For Each CellInColumn In pt.RowRange.Columns(pt.RowRange.Columns.Count).Cells
' If row is source, then add conditional formatting
If CellInColumn.Value = SourceString Then
SourceIsFound = True
SourceRow = CellInColumn.Row
Set cs = Intersect(ws.Rows(SourceRow).EntireRow, pt.DataBodyRange).FormatConditions.AddColorScale(ColorScaleType:=3)
With cs.ColorScaleCriteria(1)
.Type = xlConditionValueNumber
.Value = 40
.FormatColor.Color = RGB(248, 105, 107) ' 7039480
.FormatColor.TintAndShade = 0
End With
With cs.ColorScaleCriteria(2)
.Type = xlConditionValueNumber
.Value = 70
.FormatColor.Color = RGB(255, 235, 132) ' 8711167
.FormatColor.TintAndShade = 0
End With
With cs.ColorScaleCriteria(3)
.Type = xlConditionValueNumber
.Value = 80
.FormatColor.Color = RGB(99, 190, 123) ' 8109667
.FormatColor.TintAndShade = 0
End With
End If
' If cell is destination, then copy color of previously found sourcerow
If CellInColumn.Value = DestString Then
If SourceIsFound Then
DestRow = CellInColumn.Row
For Each CellInRow In Intersect(ws.Rows(SourceRow).EntireRow, pt.DataBodyRange).Cells
ws.Cells(DestRow, CellInRow.Column).Interior.Color = CellInRow.DisplayFormat.Interior.Color
Next CellInRow
SourceIsFound = False
End If
End If
Next CellInColumn
End Sub
I have column A with staff ids and hours worked in column K.
I would like if a staff id appears more than once to add hours worked and put the result in another column corresponding to the first instance of that staff id and the duplicates being 0.
This is for a monthly report and there may be over 2k records at any point.
As everyone else said, a Pivot Table really is the best way. If you're unsure how to use a PivotTable or what it's good for, refer to this SO post where I explain in detail.
Anyway, I put together the below VBA function to help get you started. It's by no means the most efficient approach; it also makes the following assumptions:
Sheet 1 has all the data
A has Staff Id
B has Hours
C is reserved for Total Hours
D will be available for processing status output
This of course can all be changed very easily by altering the code a bit. Review the code, it's commented for you to understand.
The reason a Status column must exist is to avoid processing a Staff Id that was already processed. You could very alter the code to avoid the need for this column, but this is the way I went about things.
CODE
Public Sub HoursForEmployeeById()
Dim currentStaffId As String
Dim totalHours As Double
Dim totalStaffRows As Integer
Dim currentStaffRow As Integer
Dim totalSearchRows As Integer
Dim currentSearchRow As Integer
Dim staffColumn As Integer
Dim hoursColumn As Integer
Dim totalHoursColumn As Integer
Dim statusColumn As Integer
'change these to appropriate columns
staffColumn = 1
hoursColumn = 2
totalHoursColumn = 3
statusColumn = 4
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
totalStaffRows = Sheet1.Cells(Rows.Count, staffColumn).End(xlUp).Row
For currentStaffRow = 2 To totalStaffRows
currentStaffId = Cells(currentStaffRow, staffColumn).Value
'if the current staff Id was not already processed (duplicate record)
If Not StrComp("Duplicate", Cells(currentStaffRow, statusColumn).Value, vbTextCompare) = 0 Then
'get this rows total hours
totalHours = CDbl(Cells(currentStaffRow, hoursColumn).Value)
'search all subsequent rows for duplicates
totalSearchRows = totalStaffRows - currentStaffRow + 1
For currentSearchRow = currentStaffRow + 1 To totalSearchRows
If StrComp(currentStaffId, Cells(currentSearchRow, staffColumn), vbTextCompare) = 0 Then
'duplicate found: log the hours worked, set them to 0, then mark as Duplicate
totalHours = totalHours + CDbl(Cells(currentSearchRow, hoursColumn).Value)
Cells(currentSearchRow, hoursColumn).Value = 0
Cells(currentSearchRow, statusColumn).Value = "Duplicate"
End If
Next
'output total hours worked and mark as Processed
Cells(currentStaffRow, totalHoursColumn).Value = totalHours
Cells(currentStaffRow, statusColumn).Value = "Processed"
totalHours = 0 'reset total hours worked
End If
Next
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
End Sub
BEFORE
AFTER
Here is the solution for the data table located in range A1:B10 with headers and results written to column C.
Sub Solution()
Range("c2:c10").Clear
Dim i
For i = 2 To 10
If WorksheetFunction.SumIf(Range("A1:a10"), Cells(i, 1), Range("C1:C10")) = 0 Then
Cells(i, "c") = WorksheetFunction.SumIf( _
Range("A1:a10"), Cells(i, 1), Range("B1:B10"))
Else
Cells(i, "c") = 0
End If
Next i
End Sub
Try below code :
Sub sample()
Dim lastRow As Integer, num As Integer, i As Integer
lastRow = Range("A65000").End(xlUp).Row
For i = 2 To lastRow
num = WorksheetFunction.Match(Cells(i, 1), Range("A1:A" & lastRow), 0)
If i = num Then
Cells(i, 3) = WorksheetFunction.SumIf(Range("A1:A" & lastRow), Cells(i, 1), Range("B1:B" & lastRow))
Else
Cells(i, 1).Interior.Color = vbYellow
End If
Next
End Sub
BEFORE
AFTER
Below code identifies duplicate value in a column and highlight with red. Hope this might be of some help.
iLastRow = Cells(chosenExcelSheet.Rows.Count, 1).End(xlUp).Row 'Determine the last row to look at
Set rangeLocation = Range("A1:A" & iLastRow)
'Checking if duplicate values exists in same column
For Each myCell In rangeLocation
If WorksheetFunction.CountIf(rangeLocation, myCell.Value) > 1 Then
myCell.Interior.ColorIndex = 3'Highlight with red Color
Else
myCell.Interior.ColorIndex = 2'Retain white Color
End If
Next
Sub SelectColoredCells()
Dim rCell As Range
Dim lColor As Long
Dim rColored As Range
'Select the color by name (8 possible)
'vbBlack, vbBlue, vbGreen, vbCyan,
'vbRed, vbMagenta, vbYellow, vbWhite
lColor = RGB(156, 0, 6)
'If you prefer, you can use the RGB function
'to specify a color
'Default was lColor = vbBlue
'lColor = RGB(0, 0, 255)
Set rColored = Nothing
For Each rCell In Selection
If rCell.Interior.Color = lColor Then
If rColored Is Nothing Then
Set rColored = rCell
Else
Set rColored = Union(rColored, rCell)
End If
End If
Next
If rColored Is Nothing Then
MsgBox "No cells match the color"
Else
rColored.Select
MsgBox "Selected cells match the color:" & _
vbCrLf & rColored.Address
End If
Set rCell = Nothing
Set rColored = Nothing
End Sub
this highlights the duplicates