Copying headers of red text to another range - excel

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

Related

Create filter based on cell value

Hi im trying to create a function in VBA which scans the top row and inserts a filter on a particular cell in the third row if the corresponding cell in the top row contains a value, if a cell is empty then it should skip to the next cell. The third row will be a header row.
Here is some code:
Sub FilterRefresh()
Dim i As Long, lastCol As Long
Dim rng As Range, cell As Range
Dim wSheet As Worksheet
Set wSheet = Worksheets("Machining")
'find the last column in row one
lastCol = wSheet.Cells(1, Columns.Count).End(xlToRight).Column 'xlToLeft
'set range from A1 to last column
Set rng = wSheet.Range(Cells(1, 1), Cells(1, lastCol)) 'will be a higher cell range
'Outline the autofilter field hierarchy
i = 1
For Each cell In rng
If cell.Value <> "" Then
wSheet.Cells(cell.row + 2, i + 1).AutoFilter Field:=i, Criteria1:=cell.Value
i = i + 1
End If
Next cell
End Sub
Try this:
For Each cell In rng
If cell.Value <> "" Then
wSheet.Cells(cell.Row + 2, cell.Column).AutoFilter Field:=cell.Column, Criteria1:=cell.Value
End If
Next cell

How to divide every cell in a column by a constant in VBA?

I am processing a data set that has about 50 columns, and the same columns are always off by a factor of ten. So, I just want to hardcode the specific columns (starting with F here) and divide every cell in the column by 10. Right now I am getting a "Type Mismatch" error. The code is below:
Sub FixData()
Dim finalRow As Long
Dim rng As Range
Dim cell As Range
finalRow = Range("A100000").End(xlUp).Row
Set rng = Range("F1:F" & finalRow)
For Each cell In rng
cell.Value = cell.Value / 10
Next cell
End Sub
why loop when you can simply paste special and divide.
errors within the cells are ignored.
in vba, here is the code
Range("G10").Copy
Range("B2:E8").PasteSpecial Paste:=xlPasteValues, Operation:=xlDivide
Application.CutCopyMode = False
test if cell is an error and then test if it is a number prior to dividing:
Sub FixData()
Dim finalRow As Long
Dim rng As Range
Dim cell As Range
finalRow = Range("A100000").End(xlUp).Row
Set rng = Range("F1:F" & finalRow)
For Each cell In rng
If Not IsError(Cell) Then
If IsNumeric(cell) and cell <> "" Then
cell.Value = cDbl(cell.Value) / 10
End If
End If
Next cell
End Sub

Clear all cells from a certain range that starts from the next blank cell in Column A

I am trying to write some VBA in excel that will clear all cells starting from the next empty cell in Column A (data starts from A2). For example, if A5 is blank then I want A5:P300 to all be cleared (as in all Formula and Data gone). And so on... so if A20 is blank then it deletes everything from A20:P300..
How would I go about writing this? I also need it to refer to the active workbook but a specific worksheet called ("Develop").
Thanks for any help provided.
Sub Clear()
Dim x As Worksheet
Dim rng, cell As Range
Set x = ThisWorkbook.Worksheets("R&DCosts(2)")
Set rng = x.Range("A2:A340").Cells(Rows.Count, 1).End(xlUp)
For Each cell In rng
If cell.Value = "" Then
x.Range(cell.Address & ":P350").ClearContents
End
End If
Next cell
End Sub
Try this code, please:
Sub clearRange_Bis()
Dim sh As Worksheet, firstEmpt As Long
Set sh = ThisWorkbook.Worksheets("R&DCosts(2)")
firstEmpt = sh.Range("A1").End(xlDown).Row + 1
If firstEmpt > 1000000 Then
sh.Range("A2:P300").Clear
Else
sh.Range("A" & firstEmpt & ":P300").Clear
End If
End Sub
A more simple solution
Option Explicit
Sub Clear()
Dim x As Worksheet
Dim rng, cell As Range
Set x = ThisWorkbook.Worksheets("RDCosts(2)") ' you cannot use "&"
Set rng = x.Range("A2:A340", Cells(Rows.Count, 1).End(xlUp))
For Each cell In rng
If cell.Value = "" Then
x.Range(cell.Address & ":P350").ClearContents
End
End If
Next cell
End Sub

How to copy an entire row to another sheet if a cell = true

I have 2 sheets, 'Initial' & 'Report1'. I'm trying to copy specific rows from 'Inital' to 'Report1' when the cell in column 'H' is = "On going".
I have the function as a button in excel but cant workout how to copy and paste the line and move onto the next cell.
Also, Column D is formula and needs to be pasted special to copy over.
I have attached the current code I have tried but it errors. Any help would be greatly appreciated.
Sub GenRep1_Click()
Dim Inti As Worksheet
Dim rep1 As Worksheet
Set Inti = ThisWorkbook.Worksheets("Inital")
Set rep1 = ThisWorkbook.Worksheets("Report1")
Dim rngA As Range
Dim cell As Range
Set rngA = Sheets("Inti").Range("H5:H9999")
For Each cell In rngA
If cell.Value = "On going" Then
cell.EntireRow.Copy
Sheets("Inti").Range("").End(xlDown).Select
ActiveSheet.Paste
End If
Next cell
End Sub
I expect the all rows in column 'H' that = "On Going" to be copied to "Report1".
I think this does what you want. You might want to improve the range you're looping through in case you only have, e.g. 100 cells of data.
A quicker approach than looping would be AutoFilter.
Sub GenRep1_Click()
Dim Inti As Worksheet
Dim rep1 As Worksheet
Set Inti = ThisWorkbook.Worksheets("Inital") 'check name - typo?
Set rep1 = ThisWorkbook.Worksheets("Report1")
Dim rngA As Range
Dim cell As Range
Set rngA = Inti.Range("H5:H9999") 'already defined worksheet so just use variable
'Set rngA = Inti.Range("H5",inti.range("H" & rows.count).end(xlup)) 'would be more efficient
For Each cell In rngA
If cell.Value = "On going" Then
cell.EntireRow.Copy
repl.Range("A" & Rows.Count).End(xlUp)(2).PasteSpecial xlValues 'copy to the other sheet
End If
Next cell
End Sub

Transferring rows into another sheet

I am trying to transfer two rows of Sheet1 (randomly and based on certain criteria) into Sheet3.
The values in cells "P2" and "P5" indicate the row number to be transferred, and column "A" has row numbers.
There's no possibility that values in "P2" and "P5" could match multiple rows in column "A". They should match 1 row each, so only one row should be copied per "P2" and "P5". Yet, sometimes I see multiple rows getting copied.
Below is the code:
Sub copyrows()
Dim tfRow As Range, cell As Object
Set tfRow = Range("A1:A") 'Range which includes the values
For Each cell In tfRow
If IsEmpty(cell) Then
Exit Sub
End If
If cell.Value = Range("P2").Value Then
cell.EntireRow.Copy
Sheet3.Select 'Target sheet
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
Sub copyrows2()
Dim tfRow2 As Range, cell As Object
Set tfRow2 = Range("A1:A") 'Range which includes the values
For Each cell In tfRow2
If IsEmpty(cell) Then
Exit Sub
End If
If cell.Value = Range("P5").Value Then
cell.EntireRow.Copy
Sheet3.Select 'Target sheet
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
As #urdearboy mentioned in the commnets above, you need to add a row to your second A column range to avoid getting the error.
To merge two conditions, in your case add an Or to your If.
To run the code faster, don't Select and Activate different sheets, it takes a long time for the code to run. Instead, use a Range object, like CopyRng and every time the if criteria is ok, you add that cell to the range using the Union function.
Read HERE about the Union functionality.
More comments inside the code's notes below.
Modified Code
Option Explicit
Sub copyrows()
Dim Sht1 As Worksheet, Sht3 As Worksheet
Dim tfRow As Range, C As Range ' use Range not Object, also try not to use Cell it's close to Cells
Dim CopyRng As Range
Dim LastRow As Long
Set Sht1 = Sheet1
Set Sht3 = Sheet3
With Sht1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' get last row with data in column A
Set tfRow = .Range("A1:A" & LastRow) 'Range which includes the values
For Each C In tfRow
If IsEmpty(C) Then
Exit Sub
End If
If C.Value = .Range("P2").Value Or C.Value = .Range("P5").Value Then ' use Or to combine both scenarios
If Not CopyRng Is Nothing Then
Set CopyRng = Application.Union(CopyRng, C) ' use Union to merge multiple ranges
Else
Set CopyRng = C
End If
End If
Next C
End With
' make sure there is at least one cells in your merged range
If Not CopyRng Is Nothing Then
' get last row with data in "sheet3"
LastRow = Sht3.Cells(Sht3.Rows.Count, "A").End(xlUp).Row
CopyRng.EntireRow.Copy Destination:=Sht3.Range("A" & LastRow + 1)
End If
End Sub

Resources