I've got multiple sheets with data in them. I've highlighted some rows in each sheet with different colors (mostly green), and I'd like to copy these, into one sheet
What I've got so far
Sub Copy_If_colored()
Dim sh As Worksheet, N As Long
Dim i As Long, M As Long, J As Long
Dim xCell As Range, xRg As Range
N = Sheets.Count - 1
M = 2
For i = 1 To N
J = Sheets(i).UsedRange.Rows.Count
Set xRg = Sheets(i).Range("A1:A" & J)
For Each xCell In xRg
If xCell.Interior.Color <> RGB(255, 255, 255) Then
Sheets(i).Range(xCell).Copy
Sheets("Recommended").Range("A" & M).PasteSpecial (xlValues)
Sheets("Recommended").Range("A" & M).PasteSpecial (xlFormats)
M = M + 1
End If
Next
Next i
End Sub
I was hoping the ..<> RGB(255, 255, 255) would catch any color since it's the value it returns in the default colorcode, right? Or would xlNone be more correct?
There are a few mistakes in your code, here is your fixed code:
Sub Copy_If_colored()
Dim sh As Worksheet
Dim i As Long, M As Long
Dim rngRow As Range
M = 2 'Start at second row, since first row contains headers
For i = 1 To Sheets.Count - 1 'Make sure "Recommended" is the last sheet
For Each rngRow In Sheets(i).UsedRange.Rows 'Going through rows instead of every cell should be considerably faster
If Sheets(i).Range("A" & rngRow.Row).Interior.ColorIndex <> xlNone Then
rngRow.Copy Sheets("Recommended").Range("A" & M)
M = M + 1
End If
Next
Next i
End Sub
To only copy the data as values, use this:
rngRow.Copy
Sheets("Recommended").Range("A" & M).PasteSpecial xlValues
Note that this does not copy formatting, if you need number formats etc. to be copied as well, add this line:
Sheets("Recommended").Range("A" & M).PasteSpecial xlFormats
If You want to compare with RGB instead of:
If CStr(xCell.Value) <> RGB(255, 255, 255) Then
try to use:
If xCell.Interior.Color <> RGB(255, 255, 255) Then
Also You need to set range xRg
Related
I have a spreadsheet that I'm trying to migrate into SQL.
The spreadsheet contains 65k rows of information over two worksheets.
The people operating the spreadsheet have been colouring the font in the rows either red, blue or yellow depending on the status of the record. Each row is a record with personal data etc. so I can't share online.
As part of the migration to SQL I need to add a column with a status field. The status field on each row should contain either 1, 2, 3, or 4 depending on whether the row has a black, red, blue or yellow font.
Based on searching here I believe it might be possible with a VBA function and a formula?
Could anyone help with what to do? I'm ok with Excel but not a power user by any means.
try using something like this in VBA. You will need to add several more ifs based on the colors you have.
CurrentSheetText="Sheet1"
LastRow = Sheets(CurrentSheetText).Cells.SpecialCells(xlCellTypeLastCell).Row
for iter = 1 to LastRow
if Sheets(CurrentSheetText).Cells(iter, 1).Interior.Color = RGB(255, 255, 0) Then
Sheets(CurrentSheetText).Cells(iter,5).value =1
End if
Next iter
This is very easily implemented with VBA. Due to the lack of information in the post, I can only write you a crude script
Sub AddCol()
Dim wb As Workbook
Dim ws As Worksheet
Dim LRow As Long, i As Long
'Target workbook
Set wb = Workbooks("NAME")
'Target worksheet
Set ws = wb.Sheets(INDEX)
'Target column
target_col = 1
'Output column
output_col = 10
With ws
'Find last row in sheet based on column A
LRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop through row 1 through LRow
For i = 1 To LRow
'populate output col based on target col's font colour
If .Cells(i, target_col).Font.Color = vbBlack Then
.Cells(i, output_col).Value = 1
ElseIf .Cells(i, target_col).Font.Color = vbRed Then
.Cells(i, output_col).Value = 2
ElseIf .Cells(i, target_col).Font.Color = vbBlue Then
.Cells(i, output_col).Value = 3
ElseIf .Cells(i, target_col).Font.Color = vbYellow Then
.Cells(i, output_col).Value = 4
End If
Next i
End With
End Sub
Many thanks for all the help!
It seems there is a very simple way to do this without any code!
I was able to use the filter function by highlighting the cheet and sorting by colour. Once I had all the red text together I was able to just add a 1 to each row and fill down.
Try the next function, please. It will return an array with the settled codes for analyzed colors. It take in consideration all standard nuances (especially for blue) of the colors in discussion:
Function colorNo(sh As Worksheet) As Variant
Dim lastR As Long, cel As Range, arr, k As Long
lastR = sh.Range("A" & rows.count).End(xlUp).row
ReDim arr(lastR - 2)
For Each cel In sh.Range("A2:A" & lastR)
Select Case cel.Font.Color
Case vbRed, 49407: arr(k) = 2: k = k + 1
Case vbBlue, 12611584, 6567712, 9851952, 14395790: arr(k) = 3: k = k + 1
Case vbYellow: arr(k) = 4: k = k + 1
Case Else: arr(k) = 1: k = k + 1
End Select
Next
colorNo = arr
End Function
The above code considers all other colors like being Black!
If in the future you will need some other colors, you should fill appropriate Case newColor lines...
It can be tested/used in this way:
Sub testColorNo()
Dim sh As Worksheet, arrCol As Variant
Set sh = ActiveSheet
arrCol = colorNo(sh)
'the array can be used like it is
'or its value can be dropped in the last empty column
'un comment the next line if you want to visually see the returned array
'but only on testing small range. Otherwise, it will be a huge string...
'Debug.Print Join(arrCol, ","): you can see the array content in Immediate Window
sh.cells(2, sh.UsedRange.Columns.count + 1).Resize(UBound(arrCol) + 1, 1).Value = _
WorksheetFunction.Transpose(arrCol)
End Sub
This should work:
Sub SubColor()
'Declarations.
Dim RngColouredRange As Range
Dim RngFirstAnswer As Range
Dim RngTarget As Range
Dim DblRow As Double
'Setting variables.
Set RngColouredRange = Range("M1:M5")
Set RngFirstAnswer = Range("N1")
'Covering each cell in RngColouredRange.
For Each RngTarget In RngColouredRange
'Checking font's color.
Select Case RngTarget.Font.Color
'In Case is black.
Case Is = 0
RngFirstAnswer.Offset(DblRow, 0) = 0
'In case is red.
Case Is = 255
RngFirstAnswer.Offset(DblRow, 0) = 1
'In case is blue.
Case Is = 12611584
RngFirstAnswer.Offset(DblRow, 0) = 2
'In case is yellow.
Case Is = 65535
RngFirstAnswer.Offset(DblRow, 0) = 3
'In other cases.
Case Else
RngFirstAnswer.Offset(DblRow, 0) = "Unclassified"
End Select
'Increasing DblRow.
DblRow = DblRow + 1
Next
End Sub
Edit the variables accordingly.
If you need to know what number refers to each of the fonts' color you have, use this:
Sub SubFontColourNumber()
'Declarations.
Dim RngColouredRange As Range
Dim RngFirstAnswer As Range
Dim RngTarget As Range
Dim DblRow As Double
'Setting variables.
Set RngColouredRange = Range("M1:M5")
Set RngFirstAnswer = Range("N1")
'Covering each cell in RngColouredRange.
For Each RngTarget In RngColouredRange
'Reporting the font's color.
RngFirstAnswer.Offset(DblRow, 0) = RngTarget.Font.Color
'Increasing DblRow.
DblRow = DblRow + 1
Next
End Sub
Like before, edit the variables accordingly.
I have a formatting macro below:
Sub Colour_whole_sheet()
Dim lastRow As Long
Dim lastColumn As Long
lastRow = Range("A1").End(xlDown).Row
lastColumn = Range("A3").End(xlToRight).Column
'Colour alternate rows purple / white
For Each cell In Range(Cells(1, 1), Cells(lastRow, lastColumn))
If cell.Row Mod 2 = 1 Then
cell.Interior.Color = RGB(242, 230, 255)
Else
cell.Interior.Color = RGB(255, 255, 255)
End If
Next cell
End Sub
It doesn't run when I call it from another macro, which is just:
Sub Run_macros()
[A bunch of other subs]
Call Colour_whole_sheet
[A bunch of other subs]
End Sub
It doesn't come up with an error - it just doesn't do anything. But when I select it specifically on its own, from View > Macros > View Macros > Run, it works fine.
Do you know why this might be?
EDIT:
Sub Colour_whole_sheet()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Calendar")
Dim lastRow As Long
Dim lastColumn As Long
lastRow = ws.Range("A1").End(xlDown).Row
lastColumn = ws.Range("A3").End(xlToRight).Column
'Colour alternate rows purple / white
For Each cell In ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastColumn))
If cell.Row Mod 2 = 1 Then
cell.Interior.Color = RGB(242, 230, 255)
Else
cell.Interior.Color = RGB(255, 255, 255)
End If
Next cell
End Sub
you might be after this revision of your code
Sub Colour_whole_sheet(Optional sht As Variant)
If IsMissing(sht) Then Set sht = ActiveSheet ' if no argument is passed assume ActiveSheet
Dim lastRow As Long
Dim lastColumn As Long
Dim i As Long
With sht ' reference passed/assumed sheet object
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row ' best way to get a column last used cell row index
lastColumn = .Cells(3, .Columns.Count).End(xlToLeft).Column ' best way to get a row last used cell column index
'Colour alternate rows purple / white
With .Range("A1", Cells(lastRow, lastColumn)) ' reference all your range
.Interior.Color = vbWhite ' color it white
For i = 1 To .Rows.Count Step 2 ' loop through referenced range uneven rows
.Rows(i).Interior.Color = RGB(242, 230, 255) ' color them with purple
Next
End With
End With
End Sub
as you can see:
it always references some sheet(be it passed through sub argument or be it the active one)
it doesn't loop through all cells, but just through uneven rows
Here Range("A1") is not specified in which worksheet this range is. Always specify a worksheet for all your Range(), Cells(), Rows() and Columns() objects.
Otherwise it is very likely that your code runs on the wrong worksheet. Note that this is applicable to all your macros (not just this one). Check if you have specified a worksheet everywhere, or your code might randomly work or fail.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'your sheet name here
Then adjust the following lines:
lastRow = ws.Range("A1").End(xlDown).Row
lastColumn = ws.Range("A3").End(xlToRight).Column
For Each cell In ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastColumn))
Also note that you can format an Excel table to get rows alternated colored.
Additional notes:
The method you used is not reliable in finding the last used row/column. Better do it the other way round. Start in the very last row and go xlUp.
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'Last used row
lastColumn = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column 'last used column in row 3
Also you don't need to go through all cells. Looping throug rows would do.
Dim i As Long
For i = 1 To lastRow
If i Mod 2 = 1 Then
ws.Rows(i).Interior.Color = RGB(242, 230, 255)
Else
ws.Rows(i)..Interior.Color = RGB(255, 255, 255)
End If
Next i
or if you don't want to color the whole row but only up to the last used column
ws.Cells(i, lastColumn).Interior.Color
Note that coloring each row on on its own can slow down a lot if there are many rows. Therefore I suggest to collect all even/uneven rows in a reference and color it at once.
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'Last used row
lastColumn = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column 'last used
Dim EvenRows As Range
Dim OddRows As Range
Dim i As Long
For i = 1 To lastRow
If i Mod 2 = 1 Then
If OddRows Is Nothing Then
Set OddRows = ws.Rows(i)
Else
Set OddRows = Union(OddROws, ws.Rows(i))
End If
Else
If EvenRows Is Nothing Then
Set EvenRows = ws.Rows(i)
Else
Set EvenRows = Union(EvenRows, ws.Rows(i))
End If
End If
Next i
If Not OddRows Is Nothing Then OddRows.Interior.Color = RGB(242, 230, 255)
If Not EvenRows Is Nothing Then EvenRows.Interior.Color = RGB(255, 255, 255)
The code I have below is checking two worksheets in order to see if the values inserted in the specific column are similar. For example, it looks to see if the values inserted in column A from sheet1 are the same as the values inserted in sheet2 column B. If yes, then the cells in sheet1 column A remain 'white' otherwise, they turn 'red'. The code works without any problems and really fast.
My problem is the following. Lets say:
I need to insert a value in sheet1 - Column A, cell A2 to A5 that match the ones from sheet2 Column B.
sheet2 column B has the following values: car, house, garden, city, country.
If in A2 I write car, A3 I leave empty, A4 country and A5 car, then A2, A4 and A5 will remain 'white' because those values are in sheet2 - Column B. However, A3 turns red even though the cell is empty - this my problem. How can I make the code to not take into consideration if that cell is empty? It should not turn red because I left the cell empty and it is not comparing anything...
I hope I explain myself somehow. Thanks for your help!
Private Sub CommandButton1_Click()
Set wb = Excel.ActiveWorkbook
Set aRec = wb.Worksheets(1)
Set bRec = wb.Worksheets(2)
Application.ScreenUpdating = False
For a = 2 To aRec.Cells(Rows.Count, "A").End(xlUp).Row
match = Application.match(aRec.Cells(c, 1).Value, bRec.Columns(2), 0)
If IsError(match) Then
aRec.Cells(c, 1).Interior.Color = RGB(255, 0, 0)
Else
aRec.Cells(c, 1).Interior.Color = RGB(255, 255, 255)
End If
Next c
End Sub
Like?
Private Sub CommandButton1_Click()
Set wb = Excel.ActiveWorkbook
Set aRec = wb.Worksheets(1)
Set bRec = wb.Worksheets(2)
Application.ScreenUpdating = False
For a = 2 To aRec.Cells(Rows.Count, "A").End(xlUp).Row
Match = Application.Match(aRec.Cells(a, 1).Value, bRec.Columns(2), 0)
If IsError(Match) And Not IsEmpty(aRec.Cells(a, 1)) Then
aRec.Cells(a, 1).Interior.Color = RGB(255, 0, 0)
Else
aRec.Cells(a, 1).Interior.Color = RGB(255, 255, 255)
End If
Next a
End Sub
With correct loop variable, Option Explicit, type declarations and switching screenupdating back on
Option Explicit
Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim aRec As Worksheet
Dim bRec As Worksheet
Dim a As Long
Dim Match As Variant
Set wb = ActiveWorkbook
Set aRec = wb.Worksheets(1)
Set bRec = wb.Worksheets(2)
Application.ScreenUpdating = False
For a = 2 To aRec.Cells(Rows.Count, "A").End(xlUp).Row
Match = Application.Match(aRec.Cells(a, 1).Value, bRec.Columns(2), 0)
If IsError(Match) And Not IsEmpty(aRec.Cells(a, 1)) Then
aRec.Cells(a, 1).Interior.Color = RGB(255, 0, 0)
Else
aRec.Cells(a, 1).Interior.Color = RGB(255, 255, 255)
End If
Next a
Application.ScreenUpdating = True
End Sub
So I have this code which lists through all sheets and compare cells in the 2nd row with cells in the 11th row. If they do not match it changes their color to red:
Dim tbl As ListObject
Dim sht As Worksheet
Dim i As Integer
'Loop through each sheet and table in the workbook
For Each sht In ThisWorkbook.Worksheets
For i = 1 To 1000
If sht.Cells(1, i) <> vbNullString Then
If sht.Cells(2, i).Value = sht.Cells(11, i).Value Then
sht.Cells(2, i).Interior.Color = xlNone
sht.Cells(11, i).Interior.Color = xlNone
Else
sht.Cells(2, i).Interior.Color = RGB(255, 0, 0)
sht.Cells(11, i).Interior.Color = RGB(255, 0, 0)
End If
Else
Exit For
End If
Next i
However in one tab it colors some matching cells as well. The data I am comparing is an exported csv. If i manually rewrite the value of the compared cell and run the code the result is correct. The formating of cells is general in both rows. Any ideas how to fix this?
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