I need help regarding the screenshot above. If possible I want a vba code that starts checking in F2 cell in row F(Unit Price) and change the adjacent values of row H and I to "01/01/2010" if the value on unit price is 0 and loop until an empty cell. Thanks in advance.
Range("F1").Select
ActiveSheet.Range("$A$1:$AI$9036").AutoFilter Field:=6, Criteria1:="0"
Range("H3").Select
ActiveCell.FormulaR1C1 = "1/1/2010"
Selection.AutoFill Destination:=Range("H3:I3"), Type:=xlFillCopy
Range("H3:I3").Select
Selection.FillDown
ActiveSheet.Range("$A$1:$AI$9036").AutoFilter Field:=6
Tried this one but the value doesnt change
Sub test()
irow = 2
Do
If (Sheets("Prices").Cells(6, 1).Value = 0) Then Cells(8, 1).Value = "01/01/2010"
irow = irow + 1
Loop Until IsEmpty(Sheets("Prices").Cells(irow, 6))
End Sub
This one works in less than 1 sec with 100,000 rows:
Option Explicit
Public Sub updateDates()
With ThisWorkbook.ActiveSheet.UsedRange
If ActiveSheet.AutoFilter Is Nothing Then .AutoFilter
.AutoFilter Field:=6, Criteria1:="0"
.Columns(8).Offset(1).Resize(.Rows.Count - 1) = "1/1/2010"
.AutoFilter
End With
End Sub
For i = 1 To 100000
With Sheets("Prices")
If .Range("F" & i).Value = "0" Then _
.Range("H" & i).Value = "01/01/2010"
End With
Next i
This one worked
Related
I'm trying to add 2 columns with formulas and autofill down to the last row, but I'm getting an
Autofill method of range class failed
when running the code. It breaks at the line that starts with Activecell.Autofill
Sub addColumnsandChange()
Dim LastRow As Integer
'Finds the value of the last row
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Selection.EntireColumn.Insert
Selection.EntireColumn.Insert
ActiveCell.FormulaR1C1 = "YoY% Change"
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveCell.FormulaR1C1 = "3 Year CAGR"
ActiveCell.Offset(1, -1).Range("A1").Select
ActiveCell.FormulaR1C1 = "=IFERROR((RC[-1]-RC[2])/RC[2],"""")"
ActiveCell.Offset(0, 1).Range("A1").Select
ActiveCell.FormulaR1C1 = "=IFERROR((RC[-2]/RC[2])^(1/3)-1,"""")"
ActiveCell.Offset(0, -1).Range("A1:B1").Select
ActiveCell.AutoFill Range("A1:B" & LastRow), Type:=xlFillDefault
Range("A1:B" & LastRow).Select
End Sub
Since incorporating the LastRow variable I have not been able to run the code.
Instead it returns a run-time error
Autofill method of range class failed
when debugging. How should I autofill and end the code?
While it is unclear on where you actually start (e.g. what cell Selection is), I suppose that it could be assumed that you know what you are doing before running the sub procedure. In any event, it is better to .FillDown or simply write the formulas all at once.
Using .FillDown:
Sub addColumnsandChange()
Dim lastRow As Long
'Finds the value of the last row
lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
With Selection.Cells(1)
.Resize(lastRow, 2).EntireColumn.Insert
.Offset(0, -2).Resize(1, 2) = Array("YoY% Change", "3 Year CAGR")
.Offset(1, -2).FormulaR1C1 = "=IFERROR((RC[-1]-RC[2])/RC[2], TEXT(,))"
.Offset(1, -1).FormulaR1C1 = "=IFERROR((RC[-2]/RC[2])^(1/3)-1, TEXT(,))"
.Offset(1, -2).Resize(lastRow - 1, 2).FillDown
.Offset(0, -2).Resize(lastRow, 2).Select
End With
End Sub
Writing all formulas at once:
Sub addColumnsandChange()
Dim lastRow As Long
'Finds the value of the last row
lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
With Selection.Cells(1)
.Resize(lastRow, 2).EntireColumn.Insert
.Offset(0, -2).Resize(1, 2) = Array("YoY% Change", "3 Year CAGR")
.Offset(1, -2).Resize(lastRow - 1, 2).FormulaR1C1 = "=IFERROR((RC[-1]-RC[2])/RC[2], TEXT(,))"
.Offset(1, -1).Resize(lastRow - 1, 2).FormulaR1C1 = "=IFERROR((RC[-2]/RC[2])^(1/3)-1, TEXT(,))"
.Offset(0, -2).Resize(lastRow, 2).Select
End With
End Sub
You are trying to autofill starting with the first row.
However, the formulas you are trying to copy are on the second row. Your first row contains header text.
Please note: You don't have to Select a cell before changing it's value. Your code would perform much faster if you would leave our those Selects. (And the code would become much easier to read and understand)
Sub test_calculateval()
Dim rnData, r As Range, ThisYearID, LR, FR, EndR, HomeCount, AwayCount, DrawCount, i As Long, Hometeam As String
ThisYearID = Sheet5.Cells(2, 1).Value - 1
Hometeam = Sheet5.Cells(2, 5)
HomeCount = 0
With Sheet1
Set rnData = Range(Range("A2"), Range("R2").End(xlDown))
With rnData
Rows("1:1").Select
Selection.AutoFilter
ActiveSheet.Range(Range("A2"), Range("R2").End(xlDown)).AutoFilter Field:=1, Criteria1:=">" & ThisYearID - 5
ActiveSheet.Range(Range("A2"), Range("R2").End(xlDown)).AutoFilter Field:=5, Criteria1:=Hometeam
LR = Range("A" & Rows.count).End(xlUp).Row
Set r = ActiveSheet.Range("A2:R" & LR).Rows.SpecialCells(xlCellTypeVisible)
FR = r.Row
EndR = Range("A" & FR).End(xlDown).Row
For Each rngarea In .SpecialCells(xlCellTypeVisible).Areas
If Range("K2:K" & LR).SpecialCells(xlCellTypeVisible).Value = "H" Then
HomeCount = HomeCount + 1
End If
Next
End With
End With
MsgBox HomeCount
End Sub
I want to check if each cell in column K (after filtering) is equal to "H", and count them.
This code is throwing a type mismatch error, what seems to be the problem
Since it is possible that
Range("K2:K" & LR).SpecialCells(xlCellTypeVisible).Value
might be returning multiple cells, so it cannot be compared to a single string value. In simple words, we cannot calculate the value of multiple cells, when they are returned to a range. The solution applies a third filter to the filtered range which filters all the records having value "H" in the column K and then we count all the visible cells.
This code will turn out to be faster than doing the same thing via loops.
Replace this existing code with this one:
Sub test_calculateval()
Dim rnData, r As Range, ThisYearID, LR, FR, EndR, HomeCount, AwayCount, DrawCount, i As Long, Hometeam As String
ThisYearID = Sheet5.Cells(2, 1).Value - 1
Hometeam = Sheet5.Cells(2, 5)
HomeCount = 0
With Sheet1
Set rnData = Range(Range("A2"), Range("R2").End(xlDown))
With rnData
.AutoFilter
.AutoFilter Field:=1, Criteria1:=">" & ThisYearID - 5
.AutoFilter Field:=5, Criteria1:=Hometeam
.AutoFilter Field:=11, Criteria1:="=H", Operator:=xlAnd
HomeCount = .Columns("K2:K" & (rnData.Rows.Count)).SpecialCells(xlCellTypeVisible).Count-1
End With
End With
MsgBox HomeCount
End Sub
Good day,
I need help with a little problem. I have a macro which compares cell with range of cells. If the equal cell is not found, it will add the cell at the end of the range. My problem is with equal cell. If it finds it, I need to add 3 to column index and write "X" into this cell.
I have solution for unequal cell but i dont know how to increase column index and write into the cell.
I have this so far:
Sub Compare()
Dim i As Integer
'Comparing cell is from another workbook
Selection.Copy
Windows("zzz.xlsm").Activate
Range("A2").Select
ActiveSheet.Paste
i = 2
Do While Cells(i, 3).Value <> ""
Set FirstRange = Range("C" & i)
If FirstRange.Value = Cells(2, 1).Value Then
MsgBox "Found"
Exit Do
End If
i = i + 1
Loop
If MsgBox = True Then
'Missing code
Else
Range("A2").Select
Selection.Copy
ActiveSheet.Range("E" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
End If
End Sub
I will appreciate any advice. Thank you for your time.
Sub Compare()
Dim i As Integer
'Comparing cell is from another workbook
Selection.Copy
Windows("zzz.xlsm").Activate
Range("A2").Select
ActiveSheet.Paste
i = 2
Do While Cells(i, 3).Value <> ""
Set FirstRange = Range("C" & i)
If FirstRange.Value = Cells(2, 1).Value Then
MsgBox "Found"
Exit Do
End If
i = i + 1
Loop
If MsgBox = True Then
Cells(i, 6) = "X" 'used to be Missing code
Else
Range("A2").Select
Selection.Copy
ActiveSheet.Range("E" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
End If
End Sub
I want to change the macro below to make it changes the color of part of the row, not the cell, based on the cell value.
If the value in cell E2 is "proof", then cells A2-E2 become red.
Sub ChangeColor()
lRow = Range("E" & Rows.Count).End(xlUp).Row
Set MR = Range("E2:E" & lRow)
For Each cell In MR
If cell.Value = "Proof" Then cell.Interior.ColorIndex = 3
Next
End Sub
It's a relatively simple change. Change cell.Interior.ColorIndex = 3 to a specific range as seen in the procedure below.
Sub ChangeColor()
lRow = Range("E" & Rows.Count).End(xlUp).Row
Set MR = Range("E2:E" & lRow)
For Each cell In MR
If cell.Value = "Proof" Then range("a" & cell.row & ":e" & cell.row).Interior.ColorIndex = 3
Next
End Sub
If you have a lot of rows to process, you may wish to abandon the loop process and work with a filter instead.
For A:E highlighting:
Sub highlight_Proof()
With ActiveSheet
With .Cells(1, 1).CurrentRegion
.Cells.Interior.Pattern = xlNone
If .AutoFilter Then .AutoFilter
.AutoFilter Field:=5, Criteria1:="=proof"
With .Offset(1, 0).Resize(.Rows.Count - 1, 5)
If CBool(Application.Subtotal(103, .Cells)) Then _
.SpecialCells(xlCellTypeVisible).Interior.ColorIndex = 3
End With
.AutoFilter
End With
End With
End Sub
For full row highlighting:
Sub highlight_Proof2()
With ActiveSheet
With .Cells(1, 1).CurrentRegion
If .AutoFilter Then .AutoFilter
.AutoFilter Field:=5, Criteria1:="=proof"
With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
If CBool(Application.Subtotal(103, .Cells)) Then _
.SpecialCells(xlCellTypeVisible).EntireRow.Interior.ColorIndex = 3
End With
.AutoFilter
End With
End With
End Sub
I haven't wildcarded the search for proof but that is a small modification. It seems that your original code was looking for the entire cell value.
With Conditional Formatting, select ColumnsA:E, HOME > Conditional Formatting, New Rule..., Use a formula to determine which cells to format, Format values where this formula is true::
=$E1="proof"
Format..., select red, OK, OK.
I need to copy values only without Formula from sheet to another. The following code does copy but only with Formula. I tried some solutions presented in this site but they give me errors.
For i = 2 To LastRow
'sheet to copy from
With Worksheets("Hoist")
'check column H value before copying
If .Cells(i, 8).Value >= -90 _
And CStr(.Cells(i, 9).Value) <> "Approved" _
And CStr(.Cells(i, 9).Value) <> "" _
And CStr(.Cells(i, 10).Value) = "" Then
'copy row to "display" sheet
.Rows(i).Copy Destination:=Worksheets("display").Range("A" & j)
j = j + 1
End If
End With
Next i
Try changing this line:
.Rows(i).Copy Destination:=Worksheets("display").Range("A" & j)
to this:
.Rows(i).Copy
Worksheets("display").Range("A" & j).PasteSpecial xlPasteValues
This however drops all formatting. To include formatting, you'll need to add another line like:
Worksheets("display").Range("A" & j).PasteSpecial xlPasteFormats
Another option is to enter a working column and use AutoFilter to avoid loops
insert a column in column A
the working column formuka is =AND(I2>-90,AND(J2<>"",J2<>"Approved"),K2="")
filter and copy the TRUE rows
delete working column A
code
Sub Recut()
Dim ws As Worksheet
Dim rng1 As Range
Set ws = Sheets("Hoist")
ws.AutoFilterMode = False
Set rng1 = Range([h2], Cells(Rows.Count, "H").End(xlUp))
ws.Columns(1).Columns.Insert
rng1.Offset(0, -8).FormulaR1C1 = "=AND(RC[8]>-90,AND(RC[9]<>"""",RC[9]<>""Approved""),RC[10]="""")"
With rng1.Offset(-1, -8).Resize(rng1.Rows.Count + 1, 1).EntireRow
.AutoFilter Field:=1, Criteria1:="TRUE"
.Copy Sheets("display").Range("A1")
Sheets("display").Columns("A").Delete
End With
ws.Columns(1).Delete
ws.AutoFilterMode = False
End Sub