I have an issue which is to copy cells that contain a color and some value in it to a range. The issue with the below code is that it copy pastes the entire range and not the ones that are in red color.
Sub testing()
Dim Myrange As Range
Dim Mycell As Range
Dim Target As Range
Set Myrange = Sheet1.Range("A3:A15")
Set Target = Sheet1.Range("B3:B15")
For Each Mycell In Myrange
If Mycell.Interior.ColorIndex = 3 Then
Mycell.Copy Target
End If
Next Mycell
End Sub
My expected result is to copy paste cells that contain only red color in the target range. (If A3 cell is red color I want B3 cell to be red color as well. But what I dont want is the entire range of the target cells to turn red)
The target range is not needed, if you are planning to offset by 1:
Sub TestMe()
Dim myRange As Range
Dim myCell As Range
Set myRange = Worksheets(1).Range("A3:A15")
For Each myCell In myRange
If myCell.Interior.ColorIndex = 3 Then
myCell.Copy myCell.Offset(0, 1)
End If
Next myCell
End Sub
Or if you need to use the target for whatever reason, looping by index would be ok in this case, as the cells are in 1 row:
Sub TestMe()
Dim myRange As Range
Dim myCell As Range
Set myRange = Worksheets(1).Range("A3:A15")
Set target = myRange.Offset(columnoffset:=1)
Dim i As Long
For i = 1 To myRange.Cells.Count
If myRange.Cells(i).Interior.ColorIndex = 3 Then
myRange.Cells(i).Copy target.Cells(i)
End If
Next i
End Sub
Related
I want to exclude A2:B2 from A1:B5 and store it as a range so that I can use it later. I have the code below which does not return error but does not seem to store anything in the range.
Sub ExcludeRange()
Dim rng As Range
Dim newRng As Range
Set rng = Sheets("Sheet1").Range("A1:B5") 'set the range you want to work with
Set newRng = rng.Offset(2, 0).Resize(rng.Rows.Count - 1, _
rng.Columns.Count)
Sheets("Sheet1").Range("C1").Value = newRng
End Sub
I want to exclude A2:B2 from A1:B5
then simply go Set newRng = Range("A1:B1, A3:B5")
Sheets("Sheet1").Range("C1").Value = newRng
you seem to want to paste a (possible) discontinuous range to a "continuous" one given its upper right cell
you have to loop through Areas property of a Range object in order to handle all the "sub-Ranges" it's made of
like follows:
Sub CopyRangeValue(rangeToPaste As Range, targetCel As Range)
With targetCel 'reference the upper-right cel of the pasted range
Dim rowOffset As Long
rowOffset = 0
Dim area As Range
For Each area In rangeToPaste.Areas ' loop through all the "sub-Ranges" the range to paste is made of
.Offset(rowOffset).Resize(area.Rows.Count, area.Columns.Count).Value = area.Value ' paste the current continuous "sub-Range" to the proper target cell
rowOffset = rowOffset + area.Rows.Count ' update the paste offset from the target cel
Next
End With
End Sub
Sub ExcludeRange()
Dim newRng As Range
With Sheets("Sheet1")
Set newRng = .Range("A1:B1, A3:B5")
CopyRangeValue newRng, .Range("K1")
End With
End Sub
I am trying to write a code for Excel in VBA which looks at a range of cells, in this example Range B4:B15, and first identifies which cells have a yellow fill color (interior color). Then of the cells colored yellow determine if any of those cells are blank.
If any of the yellow cells are blank, give a message for the entire range saying "there are yellow cells that are blank".
I'm using a For each rcell in r loop to determine which cells are yellow colored.
How do I build a new "sub-range" with only the cells colored yellow?
Sub Input_Checker_test()
Dim ws As Worksheet
Set ws = Sheets("Main")
Dim r As Range
Dim rcell As Range
Dim rmain As Range
Dim rmaincell As Range
Set r = Range("B4:B15").Cells
For Each rcell In r
If rcell.Interior.Color = 65535 Then
rcell = rmain
End If
Next rcell
For Each rmaincell In rmain
If WorksheetFunction.CountA(rmain) = 0 Then
MsgBox ("Cells are empty")
Else
MsgBox ("Cells are full")
End If
Next rmaincell
End Sub
I'm a little confused because you said font, then interior. If there is a yellow font, then there has to be a value, so I assumed you meant interior. Since you only need one of each to meet your criteria, you don't need to create a sub-range. You can test to see if any cells meet both criteria.
Sub Input_Checker_test()
Dim ws As Worksheet
Set ws = Sheets("Main")
Dim r As Range
Dim rcell As Range
Dim YellowCount as Integer
Dim EmptyCount as Integer
Set r = ws.Range("B4:B15")
For Each rcell In r
If rcell.Interior.Color = 65535 Then
YellowCount = 1
If IsEmpty(rcell) Then
EmptyCount = 1
End If
End If
Next rcell
If YellowCount > 0 Then
MsgBox "There are yellow cells"
End If
If EmptyCount > 0 Then
MsgBox "There are empty cells"
End If
End Sub
I have a range of values, I want to find the MIN, then highlight the row of this Min value.
Sub worstcase()
Set Rng = .Range("H44:H54")
worstcase = Application.WorksheetFunction.Min(Rng)
Debug.Print worstcase
How can I highlight rows based on variable worstcase?
I have my static range, and find the min value, but now I need to highlight the row of the worstcase variable.
Highlight Row With Found Criteria
The code is highlighting each row where the minimum was found. Use Exit For to highlight only the first found.
The Code
Sub worstcase()
Dim worstcase As Double ' Long for whole numbers.
Dim rng As Range
Dim cell As Range
With Worksheets("Sheet1")
Set rng = .Range("H44:H54")
worstcase = Application.WorksheetFunction.Min(rng)
Debug.Print worstcase
For Each cell In rng
If cell.Value = worstcase Then
cell.EntireRow.Interior.ColorIndex = 3 ' Hightlight whole row.
'cell.Interior.ColorIndex = 5 ' Hightlight only cell.
'Exit For ' To highlight only the first found row.
End If
Next
End With
End Sub
EDIT:
Sub worstcase()
Const cFirst As Variant = "H"
Const cLast As Variant = "Q"
Dim worstcase As Double ' Long for whole numbers.
Dim rng As Range
Dim cell As Range
With Worksheets("Sheet1")
Set rng = .Range("H44:H54")
worstcase = Application.WorksheetFunction.Min(rng)
Debug.Print worstcase
For Each cell In rng
If cell.Value = worstcase Then
.Range(.Cells(cell.Row, cFirst), .Cells(cell.Row, cLast)) _
.Interior.ColorIndex = 3 ' Hightlight cells.
'Exit For ' To highlight only the first found cells.
End If
Next
End With
End Sub
You could do it thus.
Won't work though if you have a repeated minimum.
Also you could use conditional formatting and avoid VBA.
Sub worstcase()
Dim Rng As Range, worstcase, i As Long
Set Rng = Range("H44:H54")
With Rng
worstcase = Application.WorksheetFunction.Min(.Cells)
i = Application.Match(worstcase, .Cells, 0)
.Cells(i).EntireRow.Interior.Color = vbRed
End With
End Sub
Create a conditional formatting rule based on the following formula.
=$H44=min($H$44:$H$54)
This VBA will create a CFR for rows 44:54.
With worksheets("sheet1").range("44:54")
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=$H44=min($H$44:$H$54)"
.FormatConditions(.FormatConditions.Count).Interior.Color = vbred
End With
I want to type a number in B3. If a number in the range B8 to B200 is larger than the value in B3, the cell in the range whose value is larger than that of B3's value will be cleared of its contents. (I tried doing this with the code attached)
(OR:
If a value is entered in B3, a drop down of all the values that are less than or equal to the value in B3 is generated (that way there is no way to exceed the value in B3).)
Sub ProcessLineNumberValidation()
Dim QTY As Integer
Dim ProcessNum As Integer
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Ozone Generator")
QTY = ws.Sheets("Ozone Generator").Cells(3, 2).Value
For i = 8 To 200
ProcessNum = ws.Sheets("Ozone Generator").Cells(i, 2).Value
If ProcessNum > QTY Then
ws.Sheets("Ozone Generator").Cells(i, 2).ClearContents
End If
Next i
End Sub
First, you use Set ws = Thisworkbook.Sheets("Ozone Generator")
Then, you use ws.Sheets("Ozone Generator") on multiple lines which is the likely source of your problem. If you substitute ws back in to the above line of code you get:
Thisworkbook.Sheets("Ozone Generator").Sheets("Ozone Generator")
Which is not a valid cell reference. Just use ws.Cells(.... which will result in the below code (corrected for problem and applied more standard spacing, ordering, & indentation methods to code)
Option Explicit
Sub ProcessLineNumberValidation()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Ozone Generator")
Dim QTY As Integer, ProcessNum as Integer, i
QTY = ws.Cells(3, 2).Value
For i = 8 To 200
ProcessNum = ws.Cells(i, 2).Value
If ProcessNum > QTY Then
ws.Cells(i, 2).ClearContents
End If
Next i
End Sub
You can consider this alternative that has the same output but will be quicker. For Each loops are faster than For i = loops when looping through ranges like this. Also toggling off ScreenUpdating will make this look cleaner from a user standpoint.
Sub ProcessLineNumberValidation()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Ozone Generator")
Dim MyRange As Range: Set MyRange = ws.Range("B8:B200")
Dim MyCell As Range
Application.ScreenUpdating = False
For Each MyCell In MyRange
If MyCell > ws.Cells(3, 2) Then MyCell.ClearContents
Next MyCell
Application.ScreenUpdating = True
End Sub
this could be a work for Autofilter():
Sub ProcessLineNumberValidation()
With ThisWorkbook.Sheets("Ozone Generator").Range("B7:B200") 'reference your sheet range B7:B200 (B7 is the header, values are from B8 downwards)
.AutoFilter field:=1, Criteria1:=">" & .Parent.Range("B3").Value2 ' filter referenced range with values greatre than referenced range sheet cell B3
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).ClearContents ' clear any filtered cell other than header
.Parent.AutoFilterMode = False ' remove autofilter
End With
End Sub
and if you want ProcessLineNumberValidation() being called on every "Ozone Generator" sheet B3 cell change then place this code in that sheet code pane:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$3" Then 'if cell B3 has changed
Application.EnableEvents = False ' disable events to prevent this event handler being called in a possibly infinite loop
ProcessLineNumberValidation ' process your range
Application.EnableEvents = True ' enable events back on
End If
End Sub
Goal: Have the column header of any text in red be represented in column F of the same row as the text.
Problem: Code currently references active row, and for some reason copies F2 (which is written in red). I know the code currently would be attempting to copy/paste over a cell a few times, and I'll work that out later.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, ActiveCell.Column).Copy
Range("F" & (ActiveCell.row)).Select
ActiveSheet.Paste
End If
Next cell
Next row
End Sub
Not sure if I follow your logic. Your problem is that you reference active cell but you are not defining it or changing it other than through the pasting. I think you mean to reference cell (?)
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, cell.Column).Copy Range("F" & cell.row)
End If
Next cell
Next row
End Sub
You are never changing the active cell, so the copy command is always called on row 2 of the active cell, which much be in the F column. I changed the code below to fix the issue.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet ' this should be improved to point at the correct worksheet by name
Set rng = ws.Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
cell.Copy
ws.Range("F" & (cell.row)).PasteSpecial
End If
Next cell
Next row
End Sub