How do I code this in the most simplest way?
If let's say Range("A1").value = "Thursday"
Check for duplicates on all the cells which has value in them (B1, C1, D1,...)
If a duplicate is found, select 3 cells below each of those cells Range("B2:B4") and so on...
The simplest way is to check for duplicates:
Using a WorksheetFunction
=COUNTIF(A:A,A1)>1
Using the VBA
Dim Target As Range
Dim r As Range
Set Target = Range("A1", Range("A" & Rows.Count).End(xlUp))
For Each r In Target
r.Offset(0, 1) = WorksheetFunction.CountIf(Target, r.Value) > 1
Next
If you want to remove duplicates in the first column of the range
Target.RemoveDuplicates Columns:=1, Header:=xlNo
If you wanted to expand your range to include Columns B and C
Set Target = Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, 3)
Remove duplicates in the first and third columns
Target.RemoveDuplicates Columns:=Array(1, 3), Header:=xlNo
Remove rows that contain the duplicates
Target.EntireRow.RemoveDuplicates Columns:=Array(1, 3), Header:=xlNo
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) 'Range can be updated as per your need
'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
Related
I have a range of data, with CASE ID's in Column A, and Issues (1 through 10, or Columns B through K) in Columns B onwards.
Once certain issues are ruled out as 'normal', they would be removed from the Issues sheet based on their respective column. For ex: CASE ID #25, Issue 4 is ruled OK, then it would be deleted from Row 25, Column 5 (or Column E) but the CASE ID would remain.
The goal is that by doing this check after the fact, it may leave certain rows entirely blank, from Column B onwards (since the CASE ID would already be there.)
My code doesn't function successfully. Once run, it highlights several rows that are not entirely blank in the target range.
I'm trying to pinpoint rows in the range B2:P & lastrow where the entire row is blank, and then highlight these rows and subsequently delete them.
Code:
Public Sub EmptyRows()
lastrow = Sheets("Issues").Cells(Rows.Count, "A").End(xlUp).row
On Error Resume Next
Sheets("Issues").Activate
For Each rng In Range("B2:P" & lastrow).Columns
rng.SpecialCells(xlCellTypeBlanks).EntireRow.Interior.ColorIndex = 11
'rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Next rng
Application.ScreenUpdating = True
End Sub
The purpose of first highlighting is to test the code works. If successful, they would be deleted entirely.
Your description says Columns B through K, but your code has B through P...
You can do it like this (adjust resize for actual columns involved):
Public Sub EmptyRows()
Dim lastRow As Long, sht As Worksheet, c As Range, rngDel As Range
Set sht = Sheets("Issues")
For Each c In sht.Range(sht.Range("A2"), sht.Cells(Rows.Count, 1).End(xlUp)).Cells
If Application.CountA(c.Offset(0, 1).Resize(1, 10)) = 0 Then
'build range to delete
If rngDel Is Nothing Then
Set rngDel = c
Else
Set rngDel = Application.Union(rngDel, c)
End If
End If
Next c
'anything to flag/delete ?
If Not rngDel Is Nothing Then
rngDel.EntireRow.Interior.ColorIndex = 11
'rngDel.EntireRow.Delete '<< uncomment after testing
End If
End Sub
Once run, it highlights several rows that are not entirely blank in the target range.
This is because you are selecting all blanks, instead of only rows where the entire row is blank.
See the code below
Public Sub EmptyRows()
With Sheets("Issues")
lastrow = .Cells(Rows.Count, "A").End(xlUp).row
Dim rng as Range
For Each rng In .Range("B2:B" & lastrow)
Dim blankCount as Integer
blankCount = Application.WorksheetFunction.CountA(rng.Resize(1,.Range("B:P").Columns.Count))
If blankCount = .Range("B" & lastRow & ":P" & lastRow).Columns.Count Then
Dim store as Range
If store Is Nothing Then Set store = rng Else: Set store = Union(rng, store)
End If
Next rng
End With
store.EntireRow.Interior.ColorIndex = 11
'store.EntireRow.Delete
End Sub
Gathering the ranges first and then modified them (changing color or deleting) will help to execute the code faster.
Here is another approach, using CountA
For Each cell In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Dim rng As Range
Set rng = Range("A" & cell.Row & ":" & "P" & cell.Row)
If Application.WorksheetFunction.CountA(rng) = 1 Then
rng.EntireRow.Interior.ColorIndex = 11
End If
Next cell
I've been tasked to analyse a workbook where I need to isolate the data based on the colour (red or black) that the text is in relating to the rows.
I essentially need to develop a macro that will remove all the rows that contain data (text) that is 'all black' in the range (column C-J) and leave all the rows that contain at least one cell in the range (column C-J) that contains text that is 'red' (255,0,0).
The completed result should be that every row will contain at least one cell that contains red text between between Column C-J.
The data is set our as follows:
Names:
A1,B1
A2,B2 all the way to
A2000,B2000
Data (text) is set up like the following:
C1 to J1
C2 to J2 all the way to
C2000, J2000
I've found numerous codes that conditionally colour format but I can't seem to develop one that does what I want above.
Any help will be greatly appreciated.
I may as well offer another opinion, just for fun. :-)
Copy and paste the below into a new module, select the area of cells you want to run this over and then execute the macro.
Public Sub RemoveAllRowsWithBlackText()
Dim rngCells As Range, bFoundNonBlack As Boolean, lngRow As Long
Dim lngCol As Long
Set rngCells = Selection
Application.ScreenUpdating = False
With rngCells
For lngRow = .Rows.Count To 1 Step -1
bFoundNonBlack = False
For lngCol = 1 To .Columns.Count
If .Cells(lngRow, lngCol).Font.Color <> 0 And Trim(.Cells(lngRow, lngCol)) <> "" Then
bFoundNonBlack = True
Exit For
End If
Next
If Not bFoundNonBlack Then
.Cells(lngRow, lngCol).EntireRow.Delete xlShiftUp
End If
Next
End With
Application.ScreenUpdating = True
End Sub
... it's not bound to your columns, it will move with the selection you make.
You could try:
Option Explicit
Sub test()
Dim i As Long
With ThisWorkbook.Worksheets("Sheet1")
For i = 2000 To 2 Step -1
If .Range("C" & i).Value = "" And .Range("D" & i).Value = "" And .Range("E" & i).Value = "" And .Range("F" & i).Value = "" _
And .Range("G" & i).Value = "" And .Range("H" & i).Value = "" And .Range("I" & i).Value = "" And .Range("J" & i).Value = "" Then
.Rows(i).Delete
End If
Next i
End With
End Sub
You can use AutoFilter to filter by font color. It does not matter whether the color was derived by manual formatting or conditional formatting.
In your case, you are 'proofing a negative' across many columns. A helper column appears necessary. The code below cycles through columns C:J and marks the 'helper' column every time it encounters filtered rows with a red font.
Sub anyRedFont()
Dim c As Long
With Worksheets("sheet1")
'remove any AutoFilters
If .AutoFilterMode Then .AutoFilterMode = False
'insert a 'helper' column and label it
.Columns("C").Insert
.Cells(1, "C") = "helper"
'filter for red font color
With .Range(Cells(1, "C"), .Cells(.Rows.Count, "K").End(xlUp))
'cycle through columns looking for red font
For c = 2 To 9
'fliter for red font
.AutoFilter Field:=c, Criteria1:=vbRed, _
Operator:=xlFilterFontColor, VisibleDropDown:=False
'put a value into the 'helper' column
On Error Resume Next
With .Resize(.Rows.Count - 1, 1).Offset(1, 0)
Debug.Print .SpecialCells(xlCellTypeVisible).Address(0, 0)
.SpecialCells(xlCellTypeVisible) = 1
End With
On Error GoTo 0
'remove fliter for red font
.AutoFilter Field:=c
Next c
'fliter for non-blank helper column
.AutoFilter Field:=1, Criteria1:=1, VisibleDropDown:=False
End With
'Do your work with the rows containing at least one cell
'with red font here
'remove 'helper' column
'this removes the AutoFilter since the 'helper' column
'is the primary filter column at this point
'.Columns(Application.Match("helper", .Rows(1), 0)).Delete
'remove AutoFilter (manually with Data, Data Tools, Clear)
'If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
I've commented out removing the 'helper' column. The 'helper' is the primary filter column so removing it also removes the AutoFilter.
I'm trying to solve this code's issue, which I can't run:
'========================================================================
' CHECKS IF MARKET SECTOR IS EMPTY (FOR LEDGER)
'========================================================================
Private Sub Fill_MarketSector()
Dim LastRow As Long
Dim rng As Range, C As Range
With Worksheets("Ready to upload") ' <-- here should be the Sheet's name
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' last row in column A
Set rng = .Range("A2:A" & LastRow) ' set the dynamic range to be searched
Set rng2 = .Range("F2:F" & LastRow)
' loop through all cells in column A and column F
For Each C In rng and For Each C in rng2
If rng.C.Value = "Ledger" and rng2.C.value IsEmpty Then
C.Value = "599" ' use offset to put the formula on column "L"
End If
Next C
End With
End Sub
The code should check if the column A contains word "Ledger" and column F is empty, then it should put into column F "599". It should always check to the very last row. Could you help me, please?
Thanks a lot!
You can access the accompanying cells in column F by looping through the cells in column A and using .Offset for column F then offset again to put the value in column L.
' loop through all cells in column A and column F
For Each C In rng
If LCase(C.Value) = "ledger" and IsEmpty(C.Offset(0, 5) Then
C.Offset(0, 11) = 599 'use offset to put the number on column "L"
End If
Next C
I am writing a code where basically I need to follow the sequence in logic. I am going through all the lines
Set rep = Sheets("Details")
For i = 2 To n
If Sheets("Work").Range("A:A").Find(Worksheets("Work_report").Range("E" & i).Value, lookat:=xlWhole) Is Nothing Then
Else:
o = rep.Range("A" & Rows.Count).End(xlUp).Row + 1
rep.Range("A" & o).Value = "FT_EXCEL"
rep.Range("B" & o).Value = Sheets("Start").Range("C5") & "AB" & o - 1
End If
Next i
So this the last line (there are more than 50 in original code) returns me a value of the cell C5 (20170331) & AB & the o minus 1 (because I have started at 2 (1st line header)). So this is giving 20170331AB1, but it should give 20170331AB01 (zero before the 0). This sequence works like a charm after 10, but before ten when I need to add a zero - I got stuck.
Any ideas? Thank you.
Try this:
rep.Range("B" & o).Value = Sheets("Start").Range("C5") & "AB" & Format(o - 1, "00")
you can do it in one shot with exploiting AutoFilter() method's operator xlFilterValues value
Sub main()
Dim rep As Worksheet
Dim criteriaArr As Variant
With Worksheets("Work_report") '<--| reference "Work_report" sheet
criteriaArr = Application.Transpose(.Range("E2", .Cells(.Rows.Count, "E").End(xlUp)).Value) '<--| store its column E cells content from row 2 down to last not empty one
End With
Set rep = Sheets("Details")
With Worksheets("Work") '<--| reference "Work" sheet
With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)) '<--| reference its column A cells from row 1 (header) down to last not empty one
.AutoFilter Field:=1, Criteria1:=criteriaArr, Operator:=xlFilterValues '<--| filter it with "Work_report" sheet column E content
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any filtered cells other then headers
With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) '<--| reference filtered cells skipping header
rep.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(.Rows.Count).Value = "FT_EXCEL" '<--| write 'rep' sheet column A corresponding cells content
With rep.Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(.Rows.Count)
.Formula = "=CONCATENATE(Start!$C$5,""AB"",TEXT(ROW(),""00""))" '<--| '<--| write 'rep' sheet column B corresponding cells content
.Value = .Value
End With
End With
End If
End With
.AutoFilterMode = False
End With
End Sub
The following code is doing the following:
Starting from A1, it searches for the last filled cell and selects
the cell right after it.
After selecting the first available blank cell it selects the entire row
The entire row is then colored with color index 16.
Here you go:
Sub Macro1()
Range("A1").End(xlDown).Offset(1, 0).Select
Range(Selection, Selection.End(xlToRight)).Select
With Selection.Interior
.ColorIndex = 16
End With
End Sub
This works great but I am having difficulty selecting only columns A to H within that row. I don't want to select the entire row.
Can someone please help me? I keep getting End With errors and not sure how to fix it :S
Thank you very much for your time and consideration!
That is too much selecting! How about
Sub Macro1()
currentRow = Range("A1").end(xldown).offset(1,0).row
Range(cells(currentRow, 1), cells(currentRow,8)).Interior.ColorIndex = 16
cells(currentRow,1)= " "
End Sub
Does that work?
you can set a range for your selection, also here is another method to find last row from the end of the column (version 1) - the (Rows.Count,1) represents column A (Rows.Count,2) would represents column B and so on...
this is version one: start looking for empty row from the end of column A:
Dim rowNum As Integer
rowNum = Cells(Rows.Count, 1).End(xlUp).Row + 1
Dim rng As Range
Set rng = Range(Cells(rowNum, 1), Cells(rowNum, 8))
rng.Interior.ColorIndex = 16
this is version two: start looking for empty row from the start (row 1) of column A:
Dim rowNum As Integer
rowNum = Range("A1").End(xlDown).Offset(1, 0).Row
Dim rng As Range
Set rng = Range(Cells(rowNum, 1), Cells(rowNum, 8))
rng.Interior.ColorIndex = 16
Try this:
'Declare Variables
Dim rowNum as integer
Dim YourRange as range
'Find last row by counting cells not empty and adding 1
'Assumes that all cells from A1 down are filled. Change the +1 accordingly if not
rowNum = worksheetfunction.counta(activesheet.columns(1))+1
'Set range object to column A through H of your row number
Set YourRange = Activesheet.Range("A" & rowNum & ":H" & rowNum)
'Set interior color of the rnage object instead of using Selection
YourRange.interior.colorindex=16