Copying a formula down through x number of rows - excel

I'm at a loss on this and need some help. I've lurked around at answers and have Frankensteined together some code for a macro but it just isn't working.
Here is part of what I have so far:
With ActiveSheet
Firstrow = 1
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For lrow = Lastrow To Firstrow Step -1
With .Cells(lrow, "G")
Range("G1").Select
ActiveCell.FormulaR1C1 = "=IF(ISNUMBER(RC[1]),RC[1],RC[-1])"
End With
Next lrow
End With
I have a very similar block of code before this that deletes crap from the text files I'm importing and it works perfectly through all the number of rows. When I run the same thing with this formula, it only puts the formula in G1 and doesn't cycle through the rest of the sheet. I've tried this and it works, but copies down through all million plus rows:
ActiveCell.FormulaR1C1 = "=IF(ISNUMBER(RC[1]),RC[1],RC[-1])"
Selection.AutoFill Destination:=Range("G:G")
I've tried this and then run the same code that gets rid of the text file crap but I get an error "End If without block If".

To fill the formula in one cell at a time you need to cycle through them; don't keep relying on the ActiveCell property.
With ActiveSheet
Firstrow = 1
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For lrow = Lastrow To Firstrow Step -1
.Cells(lrow, "G").FormulaR1C1 = "=IF(ISNUMBER(RC[1]),RC[1],RC[-1])"
Next lrow
End With
But you can speed things up by putting the formula into all of the cells at once.
With ActiveSheet
Firstrow = 1
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
With .Range(.Cells(Firstrow, "G"), .Cells(Lastrow, "G"))
.FormulaR1C1 = "=IF(ISNUMBER(RC[1]),RC[1],RC[-1])"
End With
End With
See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.

Another version, to dynamically select the columns based on their titles. Comments included.
Dim row As Range
Dim cell As Range
Static value As Integer
'Set row numbers
'Find the starting row. Located using Title of column "Start" plus whatever number of rows.
Dim RowStart As Long
Set FindRow = Range("A:A").Find(What:="Start", LookIn:=xlValues)
RowStart = FindRow.row + 1
'End of the range. Located using a "finished" cell
Dim RowFinish As Long
Set FindRow = Range("A:A").Find(What:="Finished", LookIn:=xlValues)
RowFinish = FindRow.row - 1
'Set range - Goes Cells(Rownumber, Columnnumber)
'Simply ammend RowStart and RowFinish to change which rows you want.
' In your case you need to change the second column number to paste in horizontally.
Set rng = Range(Cells(RowStart, 1), Cells(RowFinish, 1))
'Start the counter from the starting row.
value = RowStart
For Each row In rng.Rows
For Each cell In row.Cells
'Insert relevant formula into each cell in range.
cell.Formula = _
"=IF(ISNUMBER(RC[1]),RC[1],RC[-1])"
'Increment row variable.
value = value + 1
Next cell
Next row

Related

VBA - Conditional Formatting with dynamic formulas using VBA

I am making a project planning worksheet and writing a function to add a team member that inserts a number of grouped cells for summing up hours per week.
The new cells should have a conditional format to show when the total actual hours worked (shown in blue) exceed the planned hours worked (column M).
Example
Manage Rules Box
I am having some trouble using the range that I define in Formula1:
When I run the program, it does define the conditional format, but the formula shown in "manage rules" shows the name of the range, not the cells I am trying to format.
Any and all help is greatly appreciated!
I have defined the range of cells to be formatted, but it doesn't seem to translate to actual cell selections when using MyRange.FormatConditions.Add Type:=xlExpression, Formula1:="=sum(MyRange)>FmtHrs"
Sub Button1_Click()
Dim iCol As Long
Dim WeekCount As Long
Dim LastCol As Long
Dim RowCount As Integer
Dim FmtRow As Long
Set ws = Sheet1
'This sections adds new staff member info'
'This sections adds weeks for new staff memeber'
WeekCount = Range("B3").Value 'number of columns to add (weeks of project in B3)'
LastCol = ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column 'position of new columns at last column with data'
Columns(LastCol + 1).Insert Shift:=xlToRight
For i = 1 To WeekCount 'inserts columns for each week of project'
Columns(LastCol + 1).Insert Shift:=xlToRight
Next i
'insterns column for new staff and adds labels'
LastCol = ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column + WeekCount + 1
ActiveSheet.Cells(3, LastCol).Value = "Role"
ActiveSheet.Cells(4, LastCol).Value = "Name"
ActiveSheet.Cells(5, LastCol).Value = "Rate"
'Groups New Columns
LastCol = ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column
Range(Cells(1, LastCol - WeekCount), Cells(1, LastCol - 1)).Columns.Group
ActiveSheet.Outline.ShowLevels ColumnLevels:=1 'collapses all groups
'Adds Conditional Formats to New Rows
RowCount = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row - 1
FmtRow = RowCount
Dim FmtHrs As Long
Dim MyRange As Range
Dim condition1 As FormatCondition
For i = RowCount - 1 To 6 Step -1
FmtHrs = ActiveSheet.Cells(FmtRow, LastCol)
Set MyRange = Range(Cells(FmtRow, LastCol - WeekCount), Cells(FmtRow, LastCol - 1))
MyRange.FormatConditions.Add Type:=xlExpression, Formula1:="=sum(MyRange)>FmtHrs"
MyRange.Interior.Color = RGB(128, 100, 250)
FmtRow = FmtRow - 1
Next i
End Sub
You write "=sum(MyRange)>FmtHrs" as formula to the conditional formatting. In Excel, MyRange has no meaning, that's a VBA variable. What you want is to write the range address into the formula.
An advice: don't write the formula directly, always use an intermediate variable, that makes it much easier to check if something does not work as expected
Dim formula As String
formula = "=sum(" & MyRange.Address & ")>FmtHrs"
MyRange.FormatConditions.Add Type:=xlExpression, Formula1:=formula

Update an Empty Cell in a range

I'm looking to update a cell on a sheet when it's left empty. If there is data in column B but not in column AA, I need to insert something into column AA.
I have made the following code but have failed to make it update the cell:
Range("B2").Select
Do Until IsEmpty(ActiveCell)
Dim LoopRowNo As Integer
LoopRowNo = ActiveCell.Row
If IsEmpty(Range(Cells(LoopRowNo, 26))) Then Range(Cells(LoopRowNo, 26)).Value = "01/01/1990"
ActiveCell.Offset(1, 0).Select
Loop
Hoping someone can point me in the right direction.
Use Range or Cells, but not both.
Don't Select.
With ActiveSheet
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
Dim i As Long
For i = 2 to lastRow
If IsEmpty(.Cells(i, "AA")) And Not IsEmpty(.Cells(i, "B")) Then
.Cells(i, "AA").Value = "01/01/1990"
End If
Next
End With

How to copy data from a cell in sheet1 to sheet2, looping through each cell?

How can I cycle through sheet1 to see if there is data in that cell?
If there is no data then go to the next cell.
If there is data in the next cell paste it into sheet2.
The criteria are:
I cannot use a set range it will change as the data changes in sheet1.
I can keep sheet names a constant such as sheet1 and sheet2.
I found a way using columns and or rows yet that code has a major issue. If there is no starting data in the first cell it will not copy anything in the entire row and or column.
I am posting the code I worked with to check the data in columns but if there is no starting data it will skip the whole row.
Sub CopytoImport()
Dim wb As Workbook
Dim iCol As Long
Dim ws As Worksheet
Sheets("sheet2").Cells.ClearContents
' Loop through the column
For iCol = 1 To 22 ' Call out columns I cannot set this every time it should look threw all cells
With Worksheets("sheet1").Columns(iCol)
' Check tht column is not empty
If .Cells(1, 1).Value = "" Then
'Nothing in this column
'Do nothing
Else
' Copy the coumn to te destination
Range(.Cells(1, 1), .End(xlDown)).Copy _
Destination:=Worksheets("sheet2").Columns(iCol).Cells(1, 1)
End If
End With
Next iCol
ActiveWorkbook.Save
End Sub
Function runcode()
Call CopytoImport
End Function
Cells(1, 1) is just RANGE.("A1") you are only operating on this cell in your code. You would need Cells(1, iCol) to account for what column you are on during your loop.
You might also need a nested loop since you are looping through rows as well. The basic outline of a nested loop is as follows. Note the Cells(1,1) is replaced with the i and j representing what row and what column we are on. This might not be the fastest way to achieve the results you want but it sounds like this is what you are asking for help with. You will also need to define a lastrow (with a + 1 at the end to get the next blank cell) in your Sheet2 for when you paste the data. You would put this right under where the loop starts going through rows. This is so the lastrow of your sheet2 is recalculated each time data is being moved to that sheet. I am not going to re-write your code since you stated it is not complete but here is an example that should help you.
For j = 5 To lastcolumn
For i = 5 To lastrow
Dim lastrow2 As Long
lastrow2 = Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1
If Worksheets(2).Cells(i, j).Value <> 0 Then
Worksheets(1).Range("C" & lastrow2).Value = Worksheets(2).Cells(i, j).Value
Worksheets(1).Range("B" & lastrow2).Value = Worksheets(2).Cells(2, j).Value
End If
Next i
Next j
To find your lastrow:
dim lastrow as long
lastrow = Range("A" & rows.count).End(xlup).Row ' or whatever column contains the data
To find your last column
Dim lastcolumn As Long
lastcolumn = Worksheets(2).Cells(2, Columns.Count).End(xlToLeft).Column

Paste (dynamic) lookup formula in dynamic number of columns

I have a sheet "2018" and "2019" which i created previously. 2019 only differs from 2018 in that it may have some rows added and/or some deleted.
Form Cell "A3" and downwards i have skills listed and a "X" in the columns after if the person the column belongs to has this skill.
Now i need to fill the columns of 2019 with known X with formula below, first a bit of context code for the range selection part:
Dim rng As Range
Dim rngbegin As Range
Dim rngend As Range
Dim newrng As Range
Sheets("2018").Activate
Set rng = Application.InputBox '...and rest of the code
rng.Copy
Sheets("2019").Range("B:B").Insert Shift:=xlToRight
Sheets(2019).Activate
Set rngbegin = rng.Cells(3, 1)
Set rngend = rng.Cells(3000, rng.Columns.Count)
Set newrng = Range(rngbegin.Address & ":" & rngend.Address)
newrng.ClearContents 'To clear everything in the difined range but the headder rows
Here is a formula i could use if the columns wouldn't be varying.
Range("B3").Select
ActiveCell.Formula = "=IFERROR(LOOKUP(2,1/($A3='2018'!$A$3:D$5000),'2018'!$B$3:$B$5000),"")"
Range("B2").AutoFill Destination:=Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row)
The Formula works but i have the following problems:
1 - Required) I can't hardcode the formula for every column because the number of colums may change. (I store the number of columns as range var selected from the user via application.inputbox - that's how i inserted the colums in the new 2019 sheet)
2 - optional) I hardcoded the rows to a much higher number than are used because i didn't thnk of counting Column A and then use the range.count.Address(?) as end of the search vector. Just came into my mind lol
You will probably need to tweak a few addresses. I left much of your code unchanged so you can easily adapt what I have came up with for your purposes.
Sub Whatever()
With Sheets("2018")
' Get the address of the old range, not used later in the macro
iRows = .Cells(Rows.Count, 1).End(xlUp).Row
iCols = .Cells(3, Columns.Count).End(xlToLeft).Column
Set rngOld = Range(.Cells(3, 2), .Cells(iRows, iCols))
End With
With Sheets("2019")
' Get the address of the new range
iRows = .Cells(Rows.Count, 1).End(xlUp).Row
iCols = .Cells(2, Columns.Count).End(xlToLeft).Column
Set rngNew = Range(.Cells(3, 2), .Cells(iRows, iCols))
'Clear the new range
rngNew.Clear
' Populate the formula
' Not very elegant, VBA solution would probably look nicer
.Range("B3").Formula = "=IFERROR(if(LOOKUP(2,1/('2018'!$A$3:$A$" & iRows & " =$A3),'2018'!B$3:B$" & iRows & ")=""X"",""X"",""""),"""")"
'Fill the formula
Set rngTemp = .Range(.Cells(3, 2), .Cells(3, iCols))
rngTemp.FillRight
Set rngTemp = .Range(.Cells(3, 2), .Cells(iRows, iCols))
rngTemp.FillDown
End With
End Sub

Find, copy and paste all possible values of a cell range

I have a row of cells (the row elements may vary) and another sheet with several columns of data. Let's say on sheet 1 we have 7 columns with data(first column with titles) and on sheet 2 we have some of those titles transposed on the first row. The task is to find all possible values for each title in sheet 2. Let's say in sheet 2 on the first cell we have title X, then I need to find all values corresponding to title X in sheet 1 and to take out the results from the 8th column of sheet 1. then do the same for cell 2 in sheet 2 and so on till the end of the row.
Can someone share a hint or any suggestions that might help me.
Actually I used the following code:
Sheets("sheet2").Select
Dim Lcola As Long
Dim rng As Range
With ActiveSheet
Lcola = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set rng = .Range(.Cells(2, 1), .Cells(2, Lcola))
With rng
Range("A2").Select
ActiveCell.Formula = "=VLOOKUP(A$1,MAP!$A$1:$I$" & lRowc & _
",8,FALSE)"
Selection.AutoFill Destination:=rng, Type:=xlFillDefault
End With
End With
The thing is that I'm not sure how to repeat the function several times, or as much repetitions as I have on each variable from sheet 2 in sheet 1. And another issue that I'm facing is the vlookup function always gives me the first found item.
Use a For loop, with your last Column from Sheet2 as your counter Max.
use iCol to keep track of which Column on Sheet2 you are copying and reading from.
use iRow to keep track of which ROW has the data you want on Sheet1.
Since you know you need the 8th column on the Sheet 1, it will always be Sheets("Sheet1"),Cells(iRow, 8)
and since you know the ROW that the column headers are located in Sheet2, Sheets("Sheet2"),Cells( 1, iCol) - if the header row is 1.
Then just grab a LastRow check on the Sheet2 Column in question and add to it one at a time.
Dim iCol As Integer
Dim lastCol As Integer
Dim lastRow1 As Integer
Dim lastRow2 As Integer
Dim matchRow As Integer
Dim tempVal As String
Dim iRow As Integer
Dim nRow As Integer
Private Sub IndexMatchLoop()
lastCol = Sheets("Sheet2").Cells(1, Columns.Count).End(xlToLeft).Column
For iCol = 1 To lastCol
'Assuming your row on Sheet2 is 1.
tempVal = Sheets("Sheet2").Cells(1, iCol)
iRow = 1
Call GetLastRow
nRow = lastRow2 + 1
'Looks up the value from Sheet2 Column Header on Column1 of Sheet1 one Row at a Time
For iRow = 1 to lastRow1
If Sheets("Sheet1").Cells(iRow, 1) = tempVal Then
'Copy the data from Sheet1 Column 8 in the Rows with the value to Sheet2, the nextRow of the Col
Sheets("Sheet2").Cells(nRow, iCol) = Sheets("Sheet1").Cells(iRow, 8)
nRow = nRow + 1
End If
Next iRow
Next iCol
End Sub
Private Sub GetLastRow()
lastRow1 = Sheets("Sheet1").Cells(65532, 1).End(xlUp).Row
lastRow2 = Sheets("Sheet2").Cells(65532, iCol).End(xlUp).Row
End Sub
EDIT: typo in formula (was relying on autoComplete for "Int" instead of "Integer"
EDIT: Adding Screenshots

Resources