Average rows of variable length VBA - excel

I am trying to get a simple VBA code as part of a Macro that will put in column B the average of the values for each row.
I have code that generates a time series and fills a column per simulation such that each column is a time series starting at column C.
The number of simulations vary so I simply need something that averages the value for each point in time (ie for each row across all simulations) whilst adjusting for the number of simulations that are run (columns that are filled). I would then like it to generate a single graph of all the time series highlighting the average values that are calculated.
Many thanks if you can help!
Here, for example, is the code that takes the values for the time steps from sheet1 and places it in columnA sheet2. I would like the macro to now place the average in the appropriate row down Column B:
Sheets("Sheet1").Select
Range("E5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet2").Select
Cells(1, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Try this
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Set ws = Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("B2:B" & lRow).Formula = _
"=IF(ISERROR(AVERAGE(C2:E2)),"""",AVERAGE(C2:E2))"
End With
End Sub
FOLLOWUP
Try this
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, lCol As Long
Dim ColNm As String
Set ws = Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
ColNm = Split(.Cells(, lCol).Address, "$")(1)
.Range("B2:B" & lRow).Formula = "=IF(ISERROR(AVERAGE(C2:" _
& ColNm & _
"2)),"""",AVERAGE(C2:" & _
ColNm & "2))"
End With
End Sub

Try this although there will be lots of different variants on this code:
Sub AddAvgFormula()
With Sheets("Sheet2")
.Range("B2").FormulaR1C1 = "=AVERAGE(RC[1]:RC[3])"
.Range("B2").Copy
.Range("B2:B" & .Cells(Excel.Rows.Count, 1).End(Excel.xlUp).Row).PasteSpecial Excel.xlPasteFormulas
End With
End Sub
At the end of your current code before the End Sub add this:
Call AddAvgFormula
Here's a varient of the original code:
Sub AddAvgFormula()
With Sheets("Sheet2")
.Range("B2") = "=AVERAGE(C2:E2)"
.Range("B2").Copy
.Range("B2:B" & .Cells(Excel.Rows.Count, 1).End(Excel.xlUp).Row).PasteSpecial Excel.xlPasteFormulas
End With
End Sub
Another variant which is shorter but maybe not so intuitive:
Sub AddAvgFormula()
With Sheets("Sheet2")
.Range("B2:B" & .Cells(Excel.Rows.Count, 1).End(Excel.xlUp).Row) = "=AVERAGE(C2:E2)"
End With
End Sub

Related

Selected range of cells via VBA doesn't work

EDITED
I would like to ask you for help & revision of my VBA code as I am new to VBA.
I have pivot table with 3 columns. Via slicer I choose the items I want to add in new data table, each item must be added 3 times - therefore in the code I used loop 3 times.
The VBA works perfectly when 2 or more items are chosen.
However, when only single item is selected, the VBA crashes because the "selected copied range" does not have the same size as "pasted range" size. Basically, it selects all cells from column "F2:H2" until the end of spreadsheet.
Sub Copy()
Dim i
For i = 1 To 3
StartRange = "F2:H2"
EndRange = "F2:H2"
Set a = Range(StartRange, Range(StartRange).End(xlDown))
Set b = Range(EndRange, Range(EndRange).End(xlDown))
Union(a, b).Select
Selection.Copy
lastrow = ActiveSheet.Cells(Rows.Count, "T").End(xlUp).Row + 1
Cells(lastrow, "T").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next i
End Sub
How to modify the code, if only single item is selected, it will copy the cells in new data table as well?
I can provide a test file for reference.
Use .End(xlDown) from the header row.
Option Explicit
Sub Copy()
Dim ws As Worksheet, rng As Range
Dim i As Long, lastrow As Long
Set ws = ThisWorkbook.ActiveSheet
Set rng = ws.Range("F2", ws.Range("H1").End(xlDown))
For i = 1 To 3
lastrow = ws.Cells(Rows.Count, "T").End(xlUp).Row + 1
rng.Copy
ws.Cells(lastrow, "T").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next i
End Sub
or to copy single rows
Sub Copy2()
Const REPEAT = 3
Dim ws As Worksheet, rng As Range
Dim row As Range, lastrow As Long
Set ws = ThisWorkbook.ActiveSheet
Set rng = ws.Range("F2", ws.Range("H1").End(xlDown))
lastrow = ws.Cells(Rows.Count, "T").End(xlUp).row + 1
For Each row In rng.Rows
If Not row.Hidden Then
ws.Cells(lastrow, "T").Resize(REPEAT, row.Columns.Count).Value = row.Value
lastrow = lastrow + REPEAT
End If
Next
End Sub

Highlight Duplicate in Column and same time need value in Column T

I have written some code that, when there is a Duplicate value in Column A, then True = False would be there, same as we do in Excel, A1=A2, until the last row where we have data in A.
I am unsure how to find the last row , so i have coded the range up to T9000, but there could be data up to T3500, or sometimes T15000.
Range("A1:A5000").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes
ActiveCell.FormulaR1C1 = "Dup"
Range("T2").Select
ActiveCell.FormulaR1C1 = "=R[-1]C[-19]=RC[-19]"
Range("T3").Select
Selection.End(xlDown).Select
Range("S1048576").Select
Selection.End(xlUp).Select
Range("T9000").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
I am unsure about the placement of your Dup should it be cell A1? The rest of your code can be contracted by using your last row variable.
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
Contracted code:
Option Explicit
Sub FindDups()
Dim wb As Workbook
Dim wsSource As Worksheet
Dim lastRow As Long
Set wb = ThisWorkbook 'Variable assignments
Set wsSource = wb.Worksheets("Sheet2")
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row 'find last row by coming from the bottom of the sheet and finding last used cell in column
With wsSource
.Range("A1").FormulaR1C1 = "Dup"
.Range("A1:A" & lastRow).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes
.Range("T2:T" & lastRow).FormulaR1C1 = "=IF(RC[-19]=R[-1]C[-19],""Duplicate"", RC[-19])"
End With
End Sub

Fixing my macro to copy/paste cell values if less than X, otherwise copy/paste Y

Good day SO! :)
I'm using the following VBA to copy cells from column A (starting with row 2) with values less than the max data set value from column A, and paste them into column C (same rows), and for those column A cells that are the same value as the max data set value in column A, they are pasted into column C as zero (same rows) using an empty column B.
Cell D2 is the max value of the cell range in column A, as =MAX(A2:A100)
When running this macro (I found online) from a form button on the same sheet as the data it works like a charm:
Sub CopyOrReplaceWithZero ()
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("C2:C" & LastRow) = Evaluate("IF(A2:A" & LastRow & "=D2,B2:B" & LastRow & ",IF(A2:A" & _
LastRow & "<D2,A2:A" & LastRow & ",C2:C" & LastRow & "))")
End Sub
However, I need to specify the worksheet to run that macro on because I want to assign it to a form button on a different sheet. So when that button is clicked data is copied from that sheet (copySheet) to the target sheet (pasteSheet), where the above VBA then runs (on pasteSheet).
Here's what I have so far, and this may be a wrong-headed approach.
The first part for the copySheet and pasting into pasteSheet works fine. But the VBA above copies from copySheet and pastes into pasteSheet, while it should be copying and pasting from/to pasteSheet.
I know I'm doing something wrong but I can't figure out thus far:
Sub copyConvert()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim LastRow As Long
Set copySheet = Worksheets("sheet1")
Set pasteSheet = Worksheets("sheet2")
copySheet.Range("P1:P115").Copy
pasteSheet.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.DisplayAlerts = True
LastRow = Sheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Row
pasteSheet.Range("C2:C" & LastRow) = Evaluate("IF(A2:A" & LastRow & "=D2,B2:B" & LastRow & ",IF(A2:A" & _
LastRow & "<D2,A2:A" & LastRow & ",C2:C" & LastRow & "))")
Application.ScreenUpdating = True
End Sub
So I guess I was overthinking the issue. I found an easier solution just using IF function, as so. I hope others may mind this useful:
This function simply puts a zero into column B (in the same row) if that row in column A is the max value for the data set in column A, otherwise, if the value in each row of column A is less than the max data set value in column A its pasted into column B (same row) without modification.
=IF(A2=$C$2, A2*0, IF(A2<$C$2, A2))
Cell C2 is =MAX(A2:A100)
And I'm still using the same copy/paste command:
Sub CopyPaste
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = Worksheets("sheet1")
Set pasteSheet = Worksheets("sheet2")
copySheet.Range("P1:P115").Copy
pasteSheet.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Error deleting discontinuous entire rows

I have the following code which looks down column M to find empty cells. Each time an empty cell is found, then the entire row is deleted.
The code always leaves one row undeleted.
Can someone help to identify what is wrong with the code? I suspect that in deleting a row, the cell count goes wrong.
Private Sub CreateInvoice_Click()
Dim LastRow As Long
Dim cl As Range, rng As Range
With Sheet4
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = Sheet4.Range("M1:M" & LastRow)
For Each cl In rng
If IsEmpty(cl) Then
cl.EntireRow.Select ' MsgBox .Range("A" & cl.Row).Value & " has nothing in it"
End If
Next
End With
End Sub
I would use a filter as it's the fastest and most efficient way of deleting empty rows. Also the below doesn't use .Select method.
Sub RemoveEmpties()
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Set ws = Sheet4
lastRow = ws.Range("M" & ws.Rows.Count).End(xlUp).Row
Set rng = ws.Range("M1:M" & lastRow)
With rng
.AutoFilter Field:=1, Criteria1:=""
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
ws.AutoFilterMode = False
End Sub
Columns("M:M").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
Try using this

How to copy cells to last row and paste to another sheet?

I have an ActiveSheet script, in where I take raw data move the data to rows Q:V. I have a VBA script that runs and shows where the last row is, in this case the last row is 77.
lastrow = .Cells(.Rows.Count, "Q").End(xlUp).Row
I want to have it where it takes from Q to V last row, copy, and paste it into sheet 1...
I am guessing it will look like this, but I want to verify here first... since my normal sites I go to are down for maintenance for some reason.
Sub test()
Dim wsPOD As Worksheet
Dim wsPOT As Worksheet
Dim wsPOA As Worksheet
Dim cel As Range
Dim lastrow As Long, i As Long, Er As Long
Set wsPOD = Sheets("PO Data")
Set wsPOT = Sheets("PO Tracking")
Set wsPOA = Sheets("PO Archive")
With ActiveSheet
.AutoFilterMode = False
Intersect(.UsedRange, .Columns("A")).Cut .Range("Q1")
Intersect(.UsedRange, .Columns("D")).Cut .Range("R1")
Intersect(.UsedRange, .Columns("C")).Cut .Range("S1")
Intersect(.UsedRange, .Columns("B")).Cut .Range("T1")
Intersect(.UsedRange, .Columns("G")).Cut .Range("U1")
Intersect(.UsedRange, .Columns("F")).Cut .Range("V1")
lastrow = .Cells(.Rows.Count, "N").End(xlUp).Row
Intersect (.UsedRange.Range("Q:V" & lastrow).Copy)
Intersect (wsPOT.Range("B3:H" & lastrow).PasteSpecialxlPasteFormats)
End With
End Sub
This obviously doesn't work, if someone can help me it be appreciated.
Is this what you are trying>
With ActiveSheet
.AutoFilterMode = False
'
'~~> Rest of the code
'
lastRow = .Range("N" & Rows.Count).End(xlUp).Row
.Range("Q1:V" & lastRow).Copy
wsPOT.Range("B3").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
xlPasteFormats will only paste the formats and not the value. If you want to paste value then change xlPasteFormats to xlPasteValues
Option Explicit
Sub copylocation()
Dim EC As Long
Dim X As Long
Dim Y As Long
X = Range("B1").End(xlUp).Offset(1, 0).Row
EC = Range("b1").End(xlToLeft).Offset(0, X).Column
Windows("Book2").Activate
Range("b1:AB" & EC).Select
Selection.Copy
Windows("Book1").Activate
Range("b1").Select
ActiveSheet.Paste
End Sub

Resources