In the screenshot you can see some part of my table.
In columns A:D I put in some Value, the Value in Column B is searched in Row 1 and the Value from C:D is search in Row 2. After that it colors the cells red which are in the founded range.
The Examples "Test" and "Test2" works fine. But the 3. and 4. example does not work with my code, because the given numbers are not in Range("E2:AM2").
My question now, is how can i find the Start- and Endtemp if there are numbers like 5,15,25,152,87, ...
Here is my Code so far:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim a As Long
Dim turnCol As Range
Set ws = ThisWorkbook.Worksheets(1)
With ws
If Not Application.Intersect(Range("D:D"), Range(Target.Address)) Is Nothing Then
a = ActiveCell.Row
Turns = "Turn " & .Cells(a, 2).Value
StartTemp = Int(CDec(.Cells(a, 3).Value))
EndTemp = Int(CDec(.Cells(a, 4).Value))
Set turnCol = .Range("1:1").Find(What:=Turns)
Set startCol = .Range(.Cells(2, turnCol.Column), .Cells(2, turnCol.Column + 35)).Find(What:=StartTemp)
Set endCol = .Range(.Cells(2, turnCol.Column), .Cells(2, turnCol.Column + 35)).Find(What:=EndTemp)
.Range(.Cells(a, startCol.Column), .Cells(a, endCol.Column)).Interior.Color = RGB(255, 0, 0)
End If
End With
End Sub
Currently there's a difference between Excel sheets, having macros enabled and having macros disabled. In order to have something which works on every Excel file, I'd advise you to avoid macros, unless really needed.
In this specific case, macros are not needed indeed: you can solve your issue using conditional formatting:
Conditional formatting
Highlighting rules
Between:
=$C$2
=$D$2
Custom format (Fill with red colour)
Good luck
Related
In essence, I want to compare two sheets, one containing data from Today, the other from Yesterday, and then copy the lines with changes to a third sheet.
The code I am currently using (seen below) mostly works but has a couple errors (also broken out below) that I want to iron out.
Sub Changed()
set wsa = Sheets("Today")
Set wsb = Sheets("Yesterday")
Set wse = Sheets("Line Changes")
Dim mycell as range
Dim mydiff as integer
For each mycell in wsa.usedrange
If Not mycell.Value = wsb.Cells(mycell.Row, mycell.Column).Value Then
mycell.Interior.Color = RGB(250, 250, 50)
mycell.Range("B").Interior.Color = RGB (250, 250, 50)
mycell.EntireRow.Copy wse.Range("A" & Rows.Count).xlUp).Offset(1)
End If
Next
End Sub
Breakdown of the individual desired functions and issues within the loop:
If Not mycell.Value = wsb.Cells(mycell.Row, mycell.Column).Value Then
Compare Sheets("Today") and Sheets("Yesterday") to find differences. This line works.
mycell.Interior.Color = RGB(250, 250, 50)
Highlight the changed items on Sheets("Today"). This line works.
mycell.Range("B").Interior.Color = RGB (250, 250, 50)
For reference, Column A is just a general reference number which has no real bearing on the rest of the data, but Column B contains an alpha-numeric code specific to the actual items in each line which is why I want to highlight column B instead of A if there are changes.
Highlight Column B in Sheets("Today") if there are changes in the line to allow for easy identification of lines containing changes. The issue I run into with this function is that it doesn't actually work. It doesn't give me an error message so I haven't been able to actually identify what the problem is. This particular function is not 100% necessary so I would be amenable to just removing it.
mycell.EntireRow.Copy wse.Range("A" & Rows.Count).xlUp).Offset(1)
Copy rows with changes from Sheets("Today") and paste it in Sheets("Line Changes"). The issue I run into with this function is it copies changed lines multiple times, once for every individual change.
For example, if Columns D,E,F, and G all have changes, "D" will be highlighted and the row will be copied, then "E" will be highlighted and the row will be copied, and so on. Obviously that's not ideal if there's dozens of lines with 5 or 6 changes each.
My main issue is with that last line, I think the easiest fix would be to remove it from the current loop and add it back in later in the code so it doesn't copy over every individual change but past attempts of mine to remove it broke everything. Its a pretty large document, (1500ish rows, 32 columns) so looping the same data potentially a couple hundred times tends to crash excel. Any suggestions to fix this issue or even streamline the process would be greatly appreciated.
HighLighting Differences: a Row Range Approach
The Code
Option Explicit
Sub Changed()
' Define workbook.
Dim wb As Workbook
Set wb = ThisWorkbook
' Define worksheets.
Dim wsa As Worksheet
Set wsa = wb.Worksheets("Today")
Dim wsb As Worksheet
Set wsb = wb.Worksheets("Yesterday")
Dim wse As Worksheet
Set wse = wb.Worksheets("Line Changes")
' Define Today Used Range.
Dim rng As Range
Set rng = wsa.UsedRange
Dim RowRange As Range
Dim cel As Range
Dim copyRow As Boolean
' Loop through rows of Today Used Range.
For Each RowRange In rng.Rows
' Initialize Copy Row Boolean.
copyRow = False
' Loop through each cell in current row of Today Used Range.
For Each cel In RowRange.Cells
' Ceck value in current cell on Today worksheet against the value
' of the same cell on Yesterday Worksheet.
If Not cel.Value = wsb.Cells(cel.Row, cel.Column).Value Then
' Set Copy Row Boolean to True indicating that this
' row will be copied and the value in "B" column will be
' hightlighted.
copyRow = True
' Highlight current cell in Today Worksheet.
cel.Interior.Color = RGB(250, 250, 50)
End If
Next cel
' If any differences have been found...
If copyRow Then
RowRange.Cells(2).Interior.Color = RGB(250, 250, 50)
RowRange.Copy wse.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next
' Inform user.
MsgBox "Data transferred.", vbInformation, "Success"
End Sub
I am building a code to re-format (underlining, coloring)parts of any active worksheet (not a specific one). The code works but it is limited in that I am setting cells arbitrarily.
That is, for the first formatting function below what I am using m=2 To 500 n = 2 To 200 and I am testing the macro in a worksheet which contains values in A1:L150. What I really need is to define dynamically the active area (except for first row and first column) i.e the worksheet area that has values. So for example if a worksheet has values in the range A2:M1055 I would need the formatting to happen in this area. If yet another worksheet has cells populated in the area A2:O1500 formatting would cover that latter area. So the user would not have to define the area ideally (unless there is no other way). Same for the second formatting: I would need the entire column.
Is there a way to achieve this using Cells() ideally?
If not what would be an alternative?
The worksheet is not a table and has many blank cells.
Option Explicit
Dim ws As Worksheet
Dim m As Long
Dim n As Long
Sub format
Set ws = ActiveWorkbook.ActiveSheet
ws.Activate
'formatting sheet except first row and first column
For m = 2 To 500
For n = 2 To 200
If Cells(m, n).HasFormula = False Then
Cells(m, n).Interior.Color = RGB(0, 255, 0)
ElseIf Cells(m, n)...
End If
Next n
Next m
Set ws = ActiveSheet
ws.Activate
'formatting first column
For m = 2 To 100
For n = 1 To 1
If Cells(m, n).HasFormula = False Then
Cells(m, n).Interior.Color = RGB(255, 0, 0)
Using your existing code you can use the range selection if you have a known starting point and excel will select to the last record and last column of data.
The Selection.Address can give you the values such as A1:L150. I used split to separate the A1 and L150, you can use mid to pull out the letter and number but be careful if you go beyond the z column. You can change the reference to ReferenceStyle:=xlR1C1 to get the Value as R1C1:R150C12. Play around with RowAbsolute and ColumnAbsolute to get what you want.
Dim ws As Worksheet
Dim m As Long
Dim n As Long
Dim sRange As String
Dim sRanges() As String
Set ws = ActiveWorkbook.ActiveSheet
ws.Activate
ws.Range("A2").Select
ws.Range(Selection, Selection.End(xlDown)).Select
ws.Range(Selection, Selection.End(xlToRight)).Select
sRange = Selection.Address(ReferenceStyle:=xlA1, _
RowAbsolute:=False, ColumnAbsolute:=False)
sRanges = Split(sRange, ":")
Debug.Print sRanges(0)
Debug.Print sRanges(1)
'Prints A1 and L150
Many thanks for the replies received. I have tried all solutions with different worksheets. The one that worked with all worksheets is the one entitled "Use Find both by row and column to identify this cell" found in the link suggested by #Tim Williams
I think its because of the somewhat complex formatting of the worksheets and blank cells (or my poor skills) that I can't get the solution by #Reino4 to work; for worksheets without blank cells this works fine too: thank you! Much appreciated!
I am not entirely sure how I vote the response by Tim.
Also , thanks for the editing of the post
Stephan
I am trying to select a specific range of data and delete only the cells I identify, not the entire row.
I have included the coding that I currently have. I am trying to select everything to the left of the indicated cell, delete the range, and shift all cells up. I cannot input a specific range (ie. Range("B3:B7").delete, etc.) as the range will be changing throughout the code. I need it to be a dynamic range that will change as the code runs.
Worksheets("Sheet1").Select
Cells(2, 6).Select
ActiveCell.Offset(0, 1).Select
col = ActiveCell.Column
row = ActiveCell.Row
Cells(row, col).Select
Range(ActiveCell, ActiveCell.End(xlToLeft)).Select
Range.Delete Shift:=xlToUp
Let me know if you need any more information. Code will run up until I hit the last line (Range.Delete).
Thanks in advance.
I think this is what you are looking for. When you select any single cell, this line of code will select the range from column A and the active row, to the active column + 1 on the active row.
ThisWorkbook.Sheets("Sheet1").Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, ActiveCell.Column + 1)).Delete
I can't write it for you. But consider this technique since you seem to be doing this manually. Application.Inputbox is a built in userform that pauses the code execution until you review the range / craft your own selection.
Dim xrng As Range
Dim rngholder As Range
Dim xArray(0 To 20) As Variant
Dim x As Integer
Set xrng = Application.Selection
Set xrng = Application.InputBox("Title", "Make a selection", xrng.Address, Type:=8)
x = 0
'If xrng = "" Then Exit Sub
For Each rngholder In ActiveSheet.Range(xrng.Address)
If rngholder.Value > "" Then
xArray(x) = VBA.Trim(rngholder.Value)
Else
End If
x = x + 1
Next rngholder
In this case the Inputbox is loaded with the active cell or whatever the selection was when the macro was called and the range is populated into an array. Where you can customize this is on the line set 'xrng =' line. I would put 'set xrng = the logic to get that selection you've described so everything to the left, and up, and delete it.
edit:
Set xrng = Range(ActiveCell, Range(ActiveCell.End(xlToLeft), ActiveCell.End(xlUp))).Select
You can figure this out with a little more research into ranges. If you chose this answer you'll have an interface to handle exceptions manually, and since it seems to me you're doing this somewhat by eye, its a compromise you might benefit from in actual use.
I need to write a function to color a bunch of cells in one row based on the colors of cells in another row. I've tried some different VBA variations, but this is what I am wanting to do:
Public Function CopyColorFormat(Target As Range)
If Not Target.Interior.Color Is Nothing Then
ActiveCell.Interior.ThemeColor = Target.Interior.ThemeColor
End If
End Function
I then went to A1 and set the formula to =CopyColorFormat(C1). (C1 is Purple and I want A1 to also be shaded Purple.) However, this results in a #VALUE! error in the cell I try to put the function in.
The reason I am wanting this and not to use conditional formatting is that I need to apply this to a ton of cells (via their corresponding cell) and dont want to make a rule for each one.
I don't know much about functions, but this macro should do the trick for you.
Sub color_cells()
Application.ScreenUpdating = False
Dim currentcell As Range
Dim copycell As Range
Dim current As Long
Dim copy As Long
Set currentcell = Range("A1")
Set copycell = Range("C1")
current = 1
copy = 1
For x = 1 To 8 ' instead of 8 - enter the number of rows you want the code to run on.
If Not copycell.Interior.ColorIndex = xlNone Then
copycell.copy
currentcell.PasteSpecial xlPasteFormats
End If
current = current + 1
copy = copy + 1
Set currentcell = Range("A" & current)
Set copycell = Range("C" & copy)
Next x
Application.ScreenUpdating = True
End Sub
You might want to specify which workbook and worksheet the code runs on if you work with multiple at the same time.
I have values on Sheet 1 and I gave the background color using conditional formatting.
I want to copy only the color and paste it to the corresponding cell of sheet 2 without pasting the value.
Example if sheet 1 cell A1 has red color for specific value, transfer the color to sheet 2 A1.
I use two colors, red and white. Red is for higher value and white is for lower value.
Sub copycolor()
Dim intRow As Integer
Dim rngCopy As Range
Dim rngPaste As Range
For intRow = 1 To 20
Set rngCopy = Sheet1.Range("A" & intRow + 0)
Set rngPaste = Sheet2.Range("b" & intRow)
'Test to see if rows 500+ have a value
If rngCopy.Value <> "" Then
'Since it has a value, copy the value and color
rngPaste.Value = rngCopy.Value
rngPaste.Interior.Color = rngCopy.Interior.Color
End If
Next intRow
End Sub
rngPaste.Interior.Color = rngCopy.DisplayFormat.Interior.Color
Seems to work for me. Keep in mind that DisplayFormat is read-only and is not allowed to return value outside of the function it's used in. Also it is only available in Excel 2010 +
I was editing my answer to include the other stuff you mentioned and realized it was getting confusing to explain it all in separate chunks. Here's a recommended approach to achieve what you're saying.
Public Sub CopyColor()
Dim SourceSht As Worksheet
Dim TargetSht As Worksheet
Dim rngCopy As Range
Dim rngPaste As Range
Dim LastCopyRow As Long
Dim LastCopyColumn As Long
'Define what our source sheet and target sheet are
Set SourceSht = ThisWorkbook.Worksheets("Sheet1")
Set TargetSht = ThisWorkbook.Worksheets("Sheet2")
'Find our used space on the source sheet
LastCopyRow = SourceSht.Cells(Rows.Count, "A").End(xlUp).Row
LastCopyColumn = SourceSht.Cells(1, Columns.Count).End(xlToLeft).Column
'Setup our ranges so we can be sure we don't loop through unused space
Set rngCopy = SourceSht.Range("A1:" & SourceSht.Cells(LastCopyRow, LastCopyColumn).Address)
Set rngPaste = TargetSht.Range("A1:" & TargetSht.Cells(LastCopyRow, LastCopyColumn).Address)
'Loop through each row of each column.
' This will go through each cell in column 1, then move on to column 2
For Col = 1 To LastCopyColumn
For cel = 1 To LastCopyRow
' If the string value of our current cell is not empty.
If rngCopy.Cells(cel, Col).Value <> "" Then
'Copy the source cell displayed color and paste it in the target cell
rngPaste.Cells(cel, Col).Interior.Color = rngCopy.Cells(cel, Col).DisplayFormat.Interior.Color
End If
Next cel
Next Col
End Sub
Simplest would be to apply the same conditional formatting to Sheet2, but use the values from Sheet1 as your criteria. So if Sheet1 Cell A1 has the value that makes it red, add formatting to Sheet2 that turns Sheet2 Cell A1 red as well.
There's a good explanation of how to achieve this here.
.Interior.Color gets the actual colour of the cell rather than the conditionally formatted colour (the one you see). So you can't copy/paste this red colour in your example in this way.
I believe that the only way to get the conditionally formatted colour you see would be to recompute whatever formula you've used in your conditionally formatting criteria.
Excel 2007 conditional formatting - how to get cell color?
Edit
While #JeffK627 was giving an elegant solution, I was knocking up some rough vba code to recompute what I gather your conditional formatting does. I've done this over range A1:A20 on sheet 2. At the moment it colours the cell that contains the value itself, but only requires a little tweak to colour the equivalent cell on another sheet.
Sub ColouringIn()
Dim intColIndex As Integer
Dim dblMax As Double
Dim dblMin As Double
Dim rngCell As Range
'RGB(255, 255, 255) = white
'RGB(255, 0, 0) = red
'so need to extrapolate between
dblMax = Application.WorksheetFunction.Max(Sheet2.Range("A1:A20"))
dblMin = Application.WorksheetFunction.Min(Sheet2.Range("A1:A20"))
For Each rngCell In Sheet2.Range("A1:A20")
If IsNumeric(rngCell.Value) And rngCell.Value <> "" Then
intColIndex = (rngCell.Value - dblMin) / (dblMax - dblMin) * 255
rngCell.Interior.Color = RGB(255, intColIndex, intColIndex)
End If
Next rngCell
End Sub
Adding following example as alternative solution, as I needed something dynamic/active where color IS a required condition of data & not reliant on any other trigger.
Option1:
Dim rngPrev2Update As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cellbox As Range
Dim rngDest As Range
If Not rngPrev2Update Is Nothing Then
For Each cellbox In rngPrev2Update.Cells
Worksheets("Sheet2").Range(cellbox.Address).Interior.ColorIndex = cellbox.Interior.ColorIndex
Next cellbox
End If
Set rngPrev2Update = Target
End Sub
This will update destination cells when cursor is next moved to another cell.
Option2:
Private Sub Worksheet_Activate()
Dim cellbox As Range
Dim rngCells As Range
Set rngCells = Range("B1:B10")
For Each cellbox In rngCells.Cells
Range(cellbox.Address).Interior.ColorIndex = Worksheets("Sheet2").Range(cellbox.Address).Interior.ColorIndex
Next cellbox
End Sub
Will update relevant cells on sheet load.
Note: If you have very large data set you may want to put this into a macro button &/or filter this further for only the cells you need, otherwise this may slow your spreadsheet down.
Appreciating this was some time ago. I would like to do a similar thing however would like to append the Interior Color Reference ie. 255 to the cells value.
so if cell A1 has Hello in the cell and is Colored Red I'd want in the other worksheet cell A1: Hello | 255
Just used | as a delimiter but anything sensible...