So i have this sheet where i'd like to apply a formula every 7th row. But it can't be the same formula, it needs to "offset" the formula as well.
For example, for the first range the formula would be "=(C4+C5)-C3"; for the second range, "=(C11+C12) - C10"; and so on.
This is what i have so far:
Sub ApplyFormula()
ApplyCF Range("C6")
ApplyCF Range("C13")
'and so on, every 7 rows
'is there any other way i can apply these ranges instead of typing them?
'with an offset formula or something like that.
End Sub
Sub ApplyCF(rng As Range)
rng.Formula = "=(C4+C5)-C3"
'i'd like the macro to "offset" the formula,
'so for the C13 Range it would be "=(C11+C12) - C10"
End Sub
For your ApplyCF sub, you could do this:
Sub ApplyCF(rng As Range)
If rng.Count <> 1 Then Exit Sub ' in case your range is more than one cell
Dim prevCell As Range, twoPrevCell As Range, threePreCell As Range
Set prevCell = rng.Offset(-1, 0)
Set twoPrevCell = rng.Offset(-2, 0)
Set threeprevcell = rng.Offset(-3, 0)
rng.Formula = "=(" & twoPrevCell & "+" & prevCell & ")-" & threeprevcell
End Sub
It could definitely be tweaked, for instance, do you need to see the formula in the Formula Bar? We can evaluate that math in VBA and just put the answer in.
Per your comment, try this for every 6th cell (it's the whole macro, no need to split them):
Sub test()
' I assume you want to run this for every 6th cell in column C, starting with C1
Dim lastRow As Long
lastRow = Cells(Rows.Count, 3).End(xlUp).Row ' gets us our last row in column C with data
Dim cel As Range, rng As Range
For i = 6 To lastRow Step 6 'have to start at row 4, since any other row less than that messes up the formula
Cells(i, 3).Select ' because you can't have row 3-3
Cells(i, 3).Formula = "=(" & Cells(i - 2, 3).Address & "+" & Cells(i - 1, 3).Address & ")-" & Cells(i - 3, 3).Address
Next i
End Sub
If the formula needs to be displayed. Edited. Code below will work! you need to use the parmateter "address" to reference a cell. the parameters false or true are here to say if one needs the relative (Set to false) or absolute (set to true) referernce
Sub ApplyCF(rng As Range)
rng.Formula = "=(" & rng.Offset(-2, 0).Address(False, False) & _
"+" & rng.Offset(-1, 0).Address(False, False) & ")-" & rng.Offset(-3, 0).Address(False, False)
End Sub
Related
So I have some "working code". Specifically, I am looking at a Range in Excel, then if I see "Yes" in a cell, coloring it Yellow and doing it for all the other cells in the range. Works GREAT.
Now I would like to sort of tweak the Fixed Range and have Excel look at the each column header and only perform this coloring based on the suffixes that I say. In this case, I would only like it to do this evaluation on the columns ending in "_ty".
Here is the code I have to color the entire range of cells:
Sub ColorCellRange()
Dim c As Range
' Loop through all cells in range A1:E + last used Row in column A
For Each c In Range("A1:E" & Range("A" & Rows.Count).End(xlUp).Row)
'Look for Yes
If InStr(1, c.Text, "Yes", vbTextCompare) > 0 Then
'Color the cell RED
c.Offset(0, 0).Interior.Color = vbYellow
End If
Next
End Sub
Current output of code
Another approach: scan the column headers and decide if to process the cells below.
Sub ColorCellRange()
Dim c As Range, hdr As Range, ws As Worksheet
Set ws = ActiveSheet 'or whatever
'loop over all headers in Row 1
For Each hdr In ws.Range("A1", ws.Cells(1, Columns.Count).End(xlToLeft)).Cells
If hdr.Value Like "*_ty" Then 'is this a header we're interested in ?
For Each c In ws.Range(hdr.Offset(1), ws.Cells(Rows.Count, hdr.Column).End(xlUp)).Cells
If InStr(1, c.Text, "Yes", vbTextCompare) > 0 Then
c.Interior.Color = vbYellow
End If
Next c
End If ' like "_ty"
Next hdr
End Sub
try this:
Option Compare Text
Sub ColorCellRange()
Dim c As Range
For Each c In Range("A1:E" & Range("A" & Rows.Count).End(xlUp).Row)
If c.Value Like "*Yes*" And Cells(1, c.Column).Value Like "*_ty" Then
c.Offset(0, 0).Interior.Color = vbYellow
End If
Next c
End Sub
or you can remove Option Compare Text and convert .value to low/upper case:
Sub ColorCellRange()
Dim c As Range
For Each c In Range("A1:E" & Range("A" & Rows.Count).End(xlUp).Row)
If LCase(c.Value) Like "*yes*" And _
LCase(Cells(1, c.Column).Value) Like "*_ty" Then
c.Offset(0, 0).Interior.Color = vbYellow
End If
Next c
End Sub
I have code that is not writing anything. I get a Match problem and a mismatch error in the code line below
rtar = Evaluate("=MATCH(" & ColLetter(rng1.Columns(2).Column) & rng1.Row & "&" & ColLetter(rng1.Columns(3).Column) & rng1.Row & "," & ColLetter(rng3.Columns(1).Column) & "1:" & ColLetter(rng3.Columns(1).Column) & last2 & "&" & ColLetter(rng3.Columns(3).Column) & "1:" & ColLetter(rng3.Columns(3).Column) & last2 & ",0)")
is highlighted in yellow.
To quickly explain the code and using my Excel image below the expected written result is the grey highlight in cells F8,G8,H8. The data that gets written into these cells only occurs when any set of numbers get written in the cell range, E6:E17 and only then. The data source is from cells M5 to O17. So as an example when cell E8 (3rd line down) has the 10-1 in it the code would search the data source (3rd line down) and write from the data source cells M8/N8/O8 to cells F8/G8/H8.
Please don’t suggest using a formula because in the arr1 and arr2 I will be using about 50 or more ranges. I only want to use this code and just need help with making the necessary offset and match adjustments.
Sub PlaceNumbers()
Dim c As Range, rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range
Dim last1 As Long, last2 As Long, rtar As Long, xtar As Long
Application.ScreenUpdating = False
With ActiveSheet
'create arrays
arr1 = Array(.Range("D5:H17"))
arr2 = Array(.Range("L5:O17)) '
'loop through arrays
For i = LBound(arr1) To UBound(arr1)
Set rng1 = arr1(i)
Set rng3 = arr2(i)
last1 = .Cells(.Rows.Count, ColLetter(rng1.Columns(1).Column)).End(xlUp).Row
last2 = .Cells(.Rows.Count, ColLetter(rng3.Columns(1).Column)).End(xlUp).Row
For Each c In rng1.Offset(1, 1).Resize(, 1)
If c <> "" Then
rtar = Evaluate("=MATCH(" & ColLetter(rng1.Columns(2).Column) & rng1.Row & "&" & ColLetter(rng1.Columns(3).Column) & rng1.Row & "," & ColLetter(rng3.Columns(1).Column) & "1:" & ColLetter(rng3.Columns(1).Column) & last2 & "&" & ColLetter(rng3.Columns(3).Column) & "1:" & ColLetter(rng3.Columns(3).Column) & last2 & ",0)")
xtar = Application.Match(c.Offset(0, -2), Range(ColLetter(rng3.Columns(1).Column) & rtar & ":" & ColLetter(rng3.Columns(1).Column) & last2), 0)
With Application.WorksheetFunction
c.Offset(0, 1) = .Index(Range(ColLetter(rng3.Columns(2).Column) & rtar & ":" & ColLetter(rng3.Columns(2).Column) & last2), xtar)
c.Offset(0, 2) = .Index(Range(ColLetter(rng3.Columns(3).Column) & rtar & ":" & ColLetter(rng3.Columns(3).Column) & last2), xtar)
c.Offset(0, 3) = .Index(Range(ColLetter(rng3.Columns(4).Column) & rtar & ":" & ColLetter(rng3.Columns(4).Column) & last2), xtar)
End With
End If
Next c
Next
End With
Application.ScreenUpdating = True
End Sub
Function ColLetter(Collet As Integer) As String
ColLetter = Split(Cells(1, Collet).Address, "$")(1)
End Function
Exec image
I think the existing answer (https://stackoverflow.com/a/55959955/8811778) is better (provided it does what you need it to) as it's shorter and easier to maintain/debug.
But I include an alternative, longer version below.
If the only logic/rule that results in values in M8:O8 being written to F8:H8 is "number of rows down" (i.e. 3 rows down), then I don't think you really need to use MATCH function.
If I understand correctly, you just want the Nth row of the source data, where N corresponds to the row of whatever non-empty cell (in the yellow cells) you're currently processing.
If you change your For each c in rng1.Offset(1, 1).Resize(, 1) to instead loop through the yellow cells one row at a time, you will have access to N (otherwise you need to do some row arithmetic: c.Row - first row of yellow cells + etc...).
Note that N is the variable rowIndexRelativeToRange in the code below and is relative to the range, not the worksheet (i.e. first row in the yellow cells, not first row of the worksheet).
Option Explicit
Sub PlaceNumbers()
Dim someSheet As Worksheet
Set someSheet = ActiveSheet ' Refer to this sheet by name if possible
With someSheet
Dim arr1 As Variant
arr1 = Array(.Range("D5:H17"))
Dim arr2 As Variant
arr2 = Array(.Range("L5:O17"))
End With
'Application.ScreenUpdating = False ' Uncomment when you think code is ready/working
Dim i As Long
Dim rng1 As Range, rng2 As Range
For i = LBound(arr1) To UBound(arr1)
Set rng1 = arr1(i)
Set rng2 = arr2(i)
' We have to resize the ranges (to get rid of the first row and first column)
' You may want to re-think whether the addresses you specify (when creating arr1 and arr2)
' even need to include the first row and first column (e.g. E6:H17 instead of D5:H17)
' -- or whether you could just ensure the address passed in already excludes the first row and first column.
' It depends on whether you need to use the first row and first column (somewhere else in your code).
' But precluding them (if possible) would shorten/simplify the procedure's logic.
Dim inputColumn As Range
Set inputColumn = rng1.Offset(1, 1).Resize(rng1.Rows.Count - 1, 1) ' -1 when resizing, otherwise you're looking at range E6:E18, not E6:E17
Dim dataSourceRange As Range
Set dataSourceRange = rng2.Offset(1, 1).Resize(rng2.Rows.Count - 1, rng2.Columns.Count - 1)
Dim rowIndexRelativeToRange As Long ' This index is 1-based and relative to the range, not the worksheet.
For rowIndexRelativeToRange = 1 To inputColumn.Rows.Count
If inputColumn(rowIndexRelativeToRange, 1) <> "" Then
inputColumn(rowIndexRelativeToRange, 1).Offset(0, 1).Resize(, 3).Value = dataSourceRange(rowIndexRelativeToRange, 1).Resize(, 3).Value
End If
Next rowIndexRelativeToRange
Next i
'Application.ScreenUpdating = True ' Uncomment when you think code is ready/working
End Sub
Putting this here because I don't want to put in a comment. Why can't you use a worksheet change event? You can set the target range to multiple ranges. Place this code in the worksheet containing the two areas you showed in your example. When the value in a cell changes it will automatically update the three cells to the right.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("E6:E17")) Is Nothing Then
Range(Target.Address).Offset(, 1).Resize(1, 3).Value = Range(Target.Address).Offset(, 8).Resize(1, 3).Value
End If
End Sub
I'm trying to clean up some data in a column in Excel but it has too many rows to do it manually and the data I want is mixed up with irrelevant values.
Essentially, I need a VBA macro to search each cell in column A of Sheet1 for any row that contains the partial string "SAAM" and then copy both the full string attached to it and the next row of data directly underneath each instance to a separate sheet (Sheet2).
I expect the output to show what is shown in the attached image. I put the expected result in column B for clarity but I really want it in Sheet2 Column A.
My script currently ends up moving the full contents of the cell to Sheet2.
Sub Test()
For Each Cell In Sheets(1).Range("A:A")
If InStr(Cell.Value, "SAAM") > 0 Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow + 1).Select
Selection.Copy
lastRow = ActiveSheet.UsedRange.Rows.Count
If lastRow > 1 Then lastRow = lastRow + 1
ActiveSheet.Range("B" & lastRow).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
End If
Next
End Sub
Something like this (note this was based on looking at your code, not at the screenshot, which tells a different story...)
Sub Test()
For Each Cell In Sheets(1).UsedRange.Columns(1).Cells
If Not IsError(Cell.Value) Then
If InStr(Cell.Value, "SAAM") > 0 Then
'copy to first empty row
Cell.Resize(2,1).Entirerow.copy _
Sheets(2).Cells(rows.count, 1).end(xlup).offset(1,0)
End If 'has substring
End If 'not error
Next
End Sub
Edit: seem like you want something more like this, based on your screenshot (untested)
Sub Test()
Dim arr, i as long, sep
For Each Cell In Sheets(1).UsedRange.Columns(1).Cells
If Not IsError(Cell.Value) Then
If InStr(Cell.Value, "SAAM") > 0 Then
arr = Split(Cell.Value, vbLf) 'split cell content on newline
sep = ""
For i = lbound(arr) to ubound(arr)-1
if arr(i) like "*SAAM*" then
with cell.offset(0, 1)
.value = .value & sep & arr(i) & vbLf & arr(i+1)
sep = vbLf & vbLf
end with
end if
Next i
End If 'has substring
End If 'not error
Next
End Sub
Based on your code I’ll modify it this way:
Sub Test()
For Each Cell In Sheets(1).Range("A:A")
If InStr(Cell.Value, "SAAM") > 0 Then
matchRow = Cell.Row
Sheets(1).Cells(matchRow,1).Copy
lastRow = Sheets(2).Cells(Rows.Count,1).End(xlUp).Row + 1
Sheets(2).Range("B" & lastRow).Select
Sheets(2).PasteSpecial Paste:=xlPasteValues
Sheets(1).Select
End If
Next
End Sub
I need help to write a code which puts an R1C1 formula into a row’s cells.
The start position of the row’s will vary each time the macro is run.
Ie. If the macro is run the first time, the formula will be entered into Row B16 as R[-5]C[3]. R[-5] in the case is E12.
However, when the macro is run another time, & its entered into row B25, I still want it to reference to E3, but it references to E20.
Here is my code
Dim cell As Range, MyRange As Range
Set MyRange = Range("B1:B5000")
For Each cell In MyRange
If cell = " " And cell.Offset(, 1) <> "Record" Then
cell.FormulaR1C1 = "=SUM(R[-5]C[3]: SUM(R[-5]C[4])"
End If
Next cell
End With
You are right, my code was trying to say This row - 5, this column + 3: this row -5, this column + 4
The problem I have is that This row could be any row & I would like to use relative referencing as this formula copies down to the next row
So what I’m trying to do is this
Cell B16 = E11+F11
Cell B17 = E12+F12
Cell B18 = E13+F13 etc
Then when the macro is run again & start cell is E25, then
Cell E25 = E20+F20
Cell E26 = E21+F21
Cell E26= E22+F22 etc
So, regardless of which cell the macro points to, it will always start the calculation from E11+F11
Here is my code
Dim cell As Range, MyRange As Range
Set MyRange = Range("B1:B5000")
For Each cell In MyRange
If cell = " " And cell.Offset(, 1) <> "Record" Then
cell.FormulaR1C1 = "=SUM(R[-5]C[3]: SUM(R[-5]C[4])"
End If
Next cell
End With
You're using relative references in your formula, and the formula won't work as you're trying to say =SUM(E1:SUM(F1) if the entered in cell B6. Any rows higher than that and it will try and reference off the sheet.
To use absolute referencing use R3C5 (row 3, column 5 = E3).
At best your formula was trying to say This row - 5, this column + 3: this row -5, this column + 4
Maybe try "=SUM(R3C5:R3C4)" which is the same as =SUM($E$3:$F$3).
Also - cell = " " - the cell must contain a single space? Should it be cell = ""?
Edit:
In response to your edit - if you want the first formula to always look at E11:F11, and the next to be E12:F12, etc you can use one of these solutions:
To add the formula to all rows in one hit - this doesn't check for a cell with a space:
Public Sub Test()
Dim MyRange As Range
Dim lOffset As Long
Set MyRange = Range("B1:B5000")
With MyRange
lOffset = 11 - .Row
.FormulaR1C1 = "=IF(RC[1]<>""Record"",SUM(R[" & lOffset & "]C5:R[" & lOffset & "]C6),"""")"
End With
End Sub
To check that each cell has a space in it before adding the formula:
Public Sub Test1()
Dim MyRange As Range
Dim rCell As Range
Dim lOffset As Long
Set MyRange = Range("B30:B5000")
lOffset = 11 - MyRange.Row
For Each rCell In MyRange
If rCell = " " And rCell.Offset(, 1) <> "Record" Then
rCell.FormulaR1C1 = "=SUM(R[" & lOffset & "]C5:R[" & lOffset & "]C6)"
End If
Next rCell
End Sub
Here's the results for the second code block showing the formula always starts in row 11:
And if you change the range the formula goes in:
Edit 2:
If rows 20:24 have Record then this will place =SUM($E11:$F11) in row 25. If row 26 has a record then row 27 will have =SUM($E12:$F12)
Public Sub Test1()
Dim MyRange As Range
Dim rCell As Range
Dim lOffset As Long
Set MyRange = Range("B20:B30")
lOffset = 11
For Each rCell In MyRange
If rCell = " " And rCell.Offset(, 1) <> "Record" Then
rCell.FormulaR1C1 = "=SUM(R[" & lOffset - rCell.Row & "]C5:R[" & lOffset - rCell.Row & "]C6)"
lOffset = lOffset + 1
End If
Next rCell
End Sub
I have two columns A and B with numbers as values.
In C1 I want =A1 + B1
In C2 I want =A2 + B2
and so on. I have written the following VBA code - while it works it adds "0" after the end of the last row in range.
Let's assume my last row is A10. It adds "0" in C11 when I run the code.
How do I prevent this?
Sub macro()
Dim R As Long
R = 1
Do
Cells(R, "C").Select
R = R + 1
ActiveCell.Formula = "=sum(" & ActiveCell.Offset(0, -2) & "," &
ActiveCell.Offset(0, -1) & ")"
Loop Until IsEmpty(ActiveCell.Offset(0, -2))
End Sub
Just replace your Until condition to the following string:
Loop Until IsEmpty(ActiveCell.Offset(1, -2))
That will check the right cell for being empty. The rest of your code should remain intact.
Take a look at Do Until and Do While and While.
If you really want to iterate over cells you may go ahead. But here a method using Arrays, this will by all means reduces any performance drops that you would get looping over cells...
Option Explicit
Sub AddToRigh()
Dim i As Integer
Dim vArr As Variant
Dim LastRow As Long
'--assume you are working on Sheet 1
LastRow = Sheets(1).Cells(Rows.Count, Range("A1").Column).End(xlUp).Row
ReDim vArr(1 To LastRow)
For i = LBound(vArr) To UBound(vArr)
vArr(i) = "=Sum(RC[-2]:RC[-1])"
Next i
'--output this entire array with formulas into column C
Sheets(1).Range("C1").Resize(UBound(vArr)) = Application.Transpose(vArr)
End Sub
Output:
I'm by no means an expert in vba, but you could do this:
Sub macro()
Dim R As Long
R = 1
Do While Not IsEmpty(ActiveCell.Offset(0, -2))
Cells(R, "C").Select
R = R + 1
ActiveCell.Formula = "=sum(" & ActiveCell.Offset(0, -2) & "," &
ActiveCell.Offset(0, -1) & ")"
Loop
End Sub
I thought I'd recommend a slightly different course of action, just to give you ideas :):
Sub macro()
Dim found As Range
Set found = Range("A:A").Find("*", after:=Range("A1"), searchdirection:=xlPrevious)
If Not found Is Nothing Then
Range(Range("A1"), found).Offset(0, 2).FormulaR1C1 = "=RC[-2]+RC[-1]"
End If
End Sub