Copy/Paste last two rows into next empty row and clear certain cells (contains merged cells) - excel

I'm trying to make a command button up the top of my sheet which when pressed will copy the last 2 rows in columns A:AJ that have data and paste into the next empty row below them. I want the source style and formulas to be copied but not the manually entered data. I have an image here too to help:
So for example from the image. I want to copy rows 105/106 together and then paste them to 107/108 as they are the next empty rows(although hidden so would also need to unhide those rows).
Everything in those 2 rows should be copied except the bottom "strokes" section and par/strokes box is a formula/date/data validation/dropdown which I want copied but the strokes section to be empty as well as date/dropdown be blank too. I would like it to all look the same as well (copy the style). Filled cells to clear in that scenario would be column B, C, E:M, P:X but only on the "STROKES" row.
To put it even more basically. I want a button to push that will add another row to the table. So I have 52 there in the picture you can see, when pressed I will now have 53 below it and it be blank ready for use.
If the hidden rows need to be unhidden for this to work I can do that.
I have looked to try do it myself but I've never done anything with VBA before so I have no idea.
I hope someone can understand this request and that it is even doable.
Thanks.
Based on DecimalTurn's answer, I made some changes and here's my new code:
Private Sub CommandButton1_Click()
'Find the last row based on column D (4th)
Dim LastRow As Long
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 4).End(xlUp).Row
'Copy the range
ActiveSheet.Range("A" & (LastRow - 1) & ":" & "AJ" & LastRow).Copy
ActiveSheet.Range("A" & (LastRow + 1) & ":" & "AJ" & LastRow + 2).PasteSpecial
Application.CutCopyMode = False 'This will clear the clipboard
'Adjust numbering
ActiveSheet.Range("A" & LastRow + 1).Value2 = ActiveSheet.Range("A" & LastRow - 1).Value2 + 1
'Clear content
Dim ListOfColumnsToClear1() As Variant
Dim ListOfColumnsToClear2() As Variant
ListOfColumnsToClear1 = Array("B:C")
ListOfColumnsToClear2 = Array("E:M", "P:X")
Dim i As Long
For i = LBound(ListOfColumnsToClear1) To UBound(ListOfColumnsToClear1)
Intersect(ActiveSheet.Range("A" & (LastRow + 1) & ":" & "AJ" & LastRow + 2), ActiveSheet.Range(ListOfColumnsToClear1(i))).ClearContents
Next i
For i = LBound(ListOfColumnsToClear2) To UBound(ListOfColumnsToClear2)
Intersect(ActiveSheet.Range("A" & (LastRow + 2) & ":" & "AJ" & LastRow + 2), ActiveSheet.Range(ListOfColumnsToClear2(i))).ClearContents
Next i
End Sub
It's probably completely wrong but it did work.

To achieve what you are trying to do with VBA, I would suggest to have your code do the following (in that order):
Find the last row of data.
Define the range to copy and copy that range.
Ajust line numbering
Clear the content of the cells that need manual inputs.
Assuming you don't need to unhide any rows, the code would look like this:
Sub CopyLastTwoRows()
'Find the last row based on column D (4th)
Dim LastRow As Long
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 4).End(xlUp).Row
'Copy the range
ActiveSheet.Range("A" & (LastRow - 1) & ":" & "AJ" & LastRow).Copy
ActiveSheet.Range("A" & (LastRow + 1) & ":" & "AJ" & LastRow + 2).PasteSpecial
Application.CutCopyMode = False 'This will clear the clipboard
'Adjust numbering
ActiveSheet.Range("A" & LastRow + 1).Value2 = ActiveSheet.Range("A" & LastRow - 1).Value2 + 1
'Clear content
Dim ListOfColumnsToClear() As Variant
ListOfColumnsToClear = Array("B:C", "E:M", "P:X")
Dim i As Long
For i = LBound(ListOfColumnsToClear) To UBound(ListOfColumnsToClear)
Intersect(ActiveSheet.Range("A" & (LastRow + 2) & ":" & "AJ" & LastRow + 2), ActiveSheet.Range(ListOfColumnsToClear(i))).ClearContents
Next i
End Sub
Now, since you have merged cells, the section where we clear data will give you an error since only the bottom part of your merged cells will intersect. To solve this, we can use a function that will make sure that if there are merged cells in our range, all their cells will be included.
The code would look like this (note the new function at the end):
Sub CopyLastTwoRows()
'Find the last row based on column D (4th)
Dim LastRow As Long
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 4).End(xlUp).Row
'Copy the range
ActiveSheet.Range("A" & (LastRow - 1) & ":" & "AJ" & LastRow).Copy
ActiveSheet.Range("A" & (LastRow + 1) & ":" & "AJ" & LastRow + 2).PasteSpecial
Application.CutCopyMode = False 'This will clear the clipboard
'Adjust numbering
ActiveSheet.Range("A" & LastRow + 1).Value2 = ActiveSheet.Range("A" & LastRow - 1).Value2 + 1
'Clear content
Dim ListOfColumnsToClear() As Variant
ListOfColumnsToClear = Array("B:C", "E:M", "P:X")
Dim i As Long
For i = LBound(ListOfColumnsToClear) To UBound(ListOfColumnsToClear)
ExpandToIncludeMergedCells(Intersect(ActiveSheet.Range("A" & (LastRow + 2) & ":" & "AJ" & LastRow + 2), ActiveSheet.Range(ListOfColumnsToClear(i)))).ClearContents
Next i
End Sub
Private Function ExpandToIncludeMergedCells(ByRef Rng As Range) As Range
Dim TempRange As Range
Set TempRange = Rng.Cells(1)
Dim c As Range
For Each c In Rng
Set TempRange = Union(TempRange, c.MergeArea)
Next c
Set ExpandToIncludeMergedCells = TempRange
End Function
Finally, if you want to do this multiple times (say 10 times) by pressing a button, you would simply do:
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim i As Long
For i = 1 To 10
CopyLastTwoRows
Next i
Application.ScreenUpdating = True
End Sub
Note that I'm using Application.ScreenUpdating = False to tell Excel not to refresh the screen while the macro is running. This will make your code run much faster, but it's recommended to set it back to true at the end and to have some error handling (which I didn't include here).

Related

Using a cell in a loop to define a range in vba. I want to basically delete the row of that cell and the next 3 ones

I'm basically writing a clean up program to make it more straight forward to access data. Anywho, I ran into possibly a nomenclature error. I want to use the "current" cell in a "for" loop to delete that row and the next 3 rows. Code looks something like this:
For Each SingleCell In SingleSheet1.Range("a1:a40")
If SingleCell.Value = "S" Or SingleCell.Value = "B" Then
Range(SingleCell.Range, SingleCell.Range.Offset(4, 0)).EntireRow.Delete Shift:=xlUp
Else
End If
Next
I tried to define the range to delete as specified in the code but it gave me a runtime error
Delete backwards looping trough row number:
Sub EXAMPLE_1()
Dim i As Long
For i = 40 To 1 Step 1
If Range("A" & i).Value = "S" Or Range("A" & i).Value = "B" Then Range("A" & i & ":A" & i + 3).EntireRow.Delete Shift:=xlUp
Next i
End Sub
Sub EXAMPLE_2()
Dim i As Long
Dim LR As Long 'in case last row is not always number 40, adapt it dinamically
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = LR To 1 Step 1
If Range("A" & i).Value = "S" Or Range("A" & i).Value = "B" Then Range("A" & i & ":A" & i + 3).EntireRow.Delete Shift:=xlUp
Next i
End Sub
Your code looses the reference for the deleted rows and you should iterate backwards, if you like iteration between cells (which is slow), but a better/faster solution will be to build a Union range and delete all rows at the code end, at once:
Sub testDeleteOffset()
Dim sh As Worksheet, Urng As Range, i As Long
Set sh = ActiveSheet
For i = 1 To 40
If sh.Range("A" & i).Value = "S" Or sh.Range("A" & i).Value = "B" Then
addToRange Urng, sh.Range("A" & i, "A" & i + 3)
i = i + 4
End If
Next i
If Not Urng Is Nothing Then Urng.EntireRow.Delete xlUp
End Sub
If the involved range is huge, a better solution will be to place some markers for the necessary rows (after last existing column), sort on that marker column and delete the (consecutive marked) rows. Another column with the initial order would be necessary to re-sort according to it at the end... The idea is that building a Union range having more than 1000 areas may become slow.

How to solve Formula Error is solved in Macro

I am trying to run this formula in module but unable to figure out what is missing.
The Formula is =IF('301'!$F$10=0,"-",'301'!$F$10). Its concept is it will take the values to all those sheets started with number with their relevant Range("F10") and pasted in to "Strength" Sheet started from Range("D4") to the last row
Sub Strength()
Dim i As Long
Dim LastRow As Long
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
Application.ScreenUpdating = False
For i = 4 To LastRow
'=IF('301'!$F$10=0,"-",'301'!$F$10)
Range("D" & i).Formula = "=IF('" & Worksheets(i - 1).Name & "'!$F$10=0, ""-"" & , ' & Worksheets(i - 1).Name & '!$F$10)"
Next i
Application.ScreenUpdating = True
End Sub
I grateful if the problem is solved.
Thanks & Regards
Muneeb
Try
Range("D" & i).Formula = "=IF("& Worksheets(i- 1).Name &"!$F$10=0,""-"","& Worksheets(i- 1).Name &"!$F$10)"
or if you must the single quote (gap in worksheet name) then use
Range("D" & i).Formula = "=IF('"& Worksheets(i- 1).Name &"'!$F$10=0,""-"",'"& Worksheets(i- 1).Name &"'!$F$10)"
Using a formula template improves code clarity, avoiding errors with quotes, and outputting an array to a worksheet in a single operation increases speed. It is also advisable to specify precisely the books, worksheets, and ranges to be processed
Option Explicit
Sub Strength()
Dim i As Long, LastRow As Long, arr
Const FORMULA_T = "=IF('#'!$F$10=0,""-"",'#'!$F$10)" 'a template; # will be replaced by WS names
With ActiveSheet
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
ReDim arr(4 To LastRow, 1 To 1) 'make the array to store the formulae before output to the WS
For i = 4 To LastRow
arr(i, 1) = Replace(FORMULA_T, "#", .Parent.Worksheets(i - 1).Name) ' fill the arr with formulae
Next i
.Range("D4").Resize(UBound(arr) - LBound(arr) + 1).Formula = arr 'output the array to the WS at once
End With
End Sub

VBA, Fill up/down rows to align with last row

I am trying to delete rows till it meets my last row OR fill down rows to align with last row.
Sometimes my sheet will be like below where I need to delete rows to align with my last row number.:
However sometimes my sheet will be like below, where I need to fill down other columns:
Is there a function that can do this? I am finding it hard to determine when to fill up or fill down.
Thanks
keeping in mind the well known caveats of the use of UsedRange, you could give it a try
Dim lastRow As Long
With ActiveSheet ' <- change it to your actual sheet reference
With .UsedRange
lastRow = .Rows(.Rows.Count)
End With
End With
Please test the next code. It assumes that the reference column will be the seventh one and the one to check the 0 formulas value to be the sixth one. Your picture does not contain the columns header...
Sub DeleteRowsOrFillDownDiscontinuous()
Dim sh As Worksheet, lastR As Long, lastR1 As Long, lastCol As Long
Set sh = ActiveSheet
lastR = sh.Range("F" & rows.count).End(xlUp).row
lastR1 = Range("E" & rows.count).End(xlUp).row
lastCol = sh.cells(lastR1, Columns.count).End(xlToLeft).Column
If lastR < lastR1 Then
sh.rows(lastR + 1 & ":" & lastR1).EntireRow.Delete xlUp
ElseIf lastR > lastR1 Then
sh.Range("A" & lastR1, "E" & lastR1).AutoFill _
Destination:=sh.Range("A" & lastR1, sh.Range("E" & lastR))
sh.Range("G" & lastR1, "AG" & lastR1).AutoFill _
Destination:=sh.Range("G" & lastR1, "AG" & lastR)
sh.Range("AI" & lastR1, sh.cells(lastR1, lastCol)).AutoFill _
Destination:=sh.Range("AI" & lastR1, sh.cells(lastR, lastCol))
Else
MsgBox "Nothing te be processed. Everything aligned..."
End If
End Sub
Edited:
Adapted the code for F:F column as reference, AH:AH not changeable, too and existing columns to be processed after AH Column.
Please test it and send some feedback.

Transfer Data Row from Table to the bottom of another Table on different sheet

I am trying to transfer a row of data from one table to a new row at the bottom of another table when a date is entered into the cell(Column "AD").
When I try, data is transferred to the row under the last row of the table.
Sub TRANSFER_DATA()
For Each Cell In Worksheets("Sheet1").Range("AD2:AD1000")
If Cell.Value > 0 Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Cut
Sheets("Sheet2").Select
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
End If
Next Cell
End Sub
If i understood your question you can try this code:
Execute the macro when you have the sheet1 active
Sub TRANSFER_DATA()
Dim lastrow, i As Long
Dim ADCell as Integer
ADCell=30 ' control the column AD
'control how many data there are in column A. If you want count how many rows
'with ColumnAD change 1 in 30 (lastrow = Cells(rows.count,30).End(xlUp).Row)
lastrow = Cells(rows.count, 1).End(xlUp).Row
For i = 2 To lastrow
If Cells(i, ADCell) > 0 Then
rows(i & ":" & i).Select
Selection.Cut Worksheets("Sheet2").Range("A" & rows.count).End(xlUp).Offset(1)
End If
Next i
End Sub
I tried the code and works.
UPDATED THE POST AFTER YOUR COMMENT
Sub TRANSFER_DATA()
Dim lastrow, i, ls As Long
Dim ADCell as Integer
ADCell=30 ' control the column AD
'control how many data there are in column A. If you want count how many rows
'with ColumnAD change 1 in 30 (lastrow = Cells(rows.count,30).End(xlUp).Row)
lastrow = Cells(rows.count, 1).End(xlUp).Row
For i = 2 To lastrow
If Cells(i, ADCell) > 0 Then
rows(i & ":" & i).Select
Selection.Cut Worksheets("Sheet2").Range("A" & rows.count).End(xlUp).Offset(1)
End If
Next i
With Sheets("sheet2")
ls = .Cells(.rows.count, ADCell).End(xlUp).Row
.ListObjects("TableName").Resize Range("$A$1:$AD$" & ls)
End With
End Sub
the updated code have another variable, ls. This variable has the number of not empty rows of sheet2. ListObjects.("name of your table") insert the new data (rows) into the table.
I hope this helps

VBA, how to insert a dynamic / relative cell reference into a .formulaArray method?

I have the following code:
With Sh.Range("A1:A" & LastRow + 1).Offset(0, 4)
.FormulaArray = "=MAX(IF(A2:A" & LastRow + 1 & "= ** , D2:D" & LastRow + 1 & "))"
.Value = .Value
End With
In the place where I have **, I would want a dynamic cell reference. If I was using .formulaR1C1, I would have inserted RC[-1], but I can't use that with a .formulaArray.
Does anyone know how I can insert a relative cell reference that would change as the formula being pasted within the range?
Thank you
EDIT # 1
The whole code looks like this:
Sub RemoveDuplicates_SumMarketValue()
Dim Sh As Worksheet
Dim LastRow As Long
Dim Rng As Range
Set Sh = Worksheets(1)
Sh.Columns(6).Insert
LastRow = Sh.Range("A65536").End(xlUp).Row
With Sh.Range("A1:A" & LastRow).Offset(0, 5)
.FormulaR1C1 = "=IF(COUNTIF(R1C[-5]:RC[-5],RC[-5])>1,"""",SUMIF(R1C[-5]:R[" & LastRow & "]C[-5],RC[-5],R1C[-1]:R[" & LastRow & "]C[-1]))"
.Value = .Value
End With
Sh.Columns(5).Delete
Sh.Rows(1).Insert
Sh.Columns(5).Insert
With Sh.Range("A1:A" & LastRow + 1).Offset(0, 4)
.FormulaArray = "=MAX(IF(A2:A" & LastRow + 1 & "= A1 , D2:D" & LastRow + 1 & "))"
.Value = .Value
End With
Set Rng = Sh.Range("E1:E" & LastRow + 1)
With Rng
.AutoFilter Field:=1, Criteria1:="="
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
End Sub
This purpose of this code, is too look though a sample of data and
find duplicates
sum up values in 5th column associated with duplicates
remove duplicate rows (except the one that carries the sum from 5th column)
Now I also want it to have the max value from column 4th of all the duplicates to be retained in the final version, but I can't get the array formula to reference the row correctly.
EDIT : Try pasting this inside the "ThisWorkbook" code sheet :
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Sh As Worksheet
Dim LastRow As Long
Dim Rng As Range
Set Sh = Worksheets(1)
LastRow = Sh.Range("A65536").End(xlUp).Row
With Sh.Range("A1:A" & LastRow).Offset(0, 5)
.FormulaR1C1 = "=IF(COUNTIF(R1C[-5]:RC[-5],RC[-5])>1,"""",SUMIF(R1C[-5]:R[" & LastRow & "]C[-5],RC[-5],R1C[-1]:R[" & LastRow & "]C[-1]))"
.Value = .Value
End With
With Sh.Range("A1:A" & LastRow + 1).Offset(0, 4)
.FormulaArray = "=MAX(IF(A2:A" & LastRow + 1 & "= A1 , D2:D" & LastRow + 1 & "))"
.Value = .Value
End With
'This section you might want to remove from this routine
Set Rng = Sh.Range("E1:E" & LastRow + 1)
With Rng
.AutoFilter Field:=1, Criteria1:="="
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
End Sub
It basically is the same as your function, but it doesn't remove the columns or add any rows. What will happen is everytime one of your cell's content changes, this macro will run automatically, updating the formulas in the cells.
The closest you can get to achieving that, is having a macro in the background that will be running everytime a change is made to the sheet. If you have tens of thousands of rows, or a REALLY slow computer, this may not be the ideal solution. If this is not the case, however, you may find it very easy to get your code to work with very little changes.
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'Update your formula here with the new content/reference
' (your code + some changes to update where the last row is)
End Sub
Paste this inside the "ThisWorkbook", and simply place your code inside it.
This is what I came up with to solve the issue of the .formulaArray not accepting RC cell reference notation. I just used a loop to insert the array formula into each cell and reference the target row by using the loop variable i.
Code:
Sub RemoveDuplicates_SumMarketValue()
Dim Sh As Worksheet
Dim LastRow As Long
Dim Rng As Range
Dim targetcell As Range
Set Sh = Worksheets(1)
Sh.Columns(6).Insert
LastRow = Sh.Range("A65536").End(xlUp).Row
With Sh.Range("A1:A" & LastRow).Offset(0, 5)
.FormulaR1C1 = "=IF(COUNTIF(R1C[-5]:RC[-5],RC[-5])>1,"""",SUMIF(R1C[-5]:R[" & LastRow & "]C[-5],RC[-5],R1C[-1]:R[" & LastRow & "]C[-1]))"
.Value = .Value
End With
Sh.Columns(5).Delete
Sh.Rows(1).Insert
Sh.Columns(5).Insert
For i = 2 To LastRow + 1
Cells(i, 5).FormulaArray = "=MAX(IF(A2:A" & LastRow + 1 & "= A" & i & " , D2:D" & LastRow + 1 & "))"
Cells(i, 5) = Cells(i, 5).Value
Next
Sh.Columns(4).Delete
Set Rng = Sh.Range("E1:E" & LastRow + 1)
With Rng
.AutoFilter Field:=1, Criteria1:="="
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
Sheets(1).Cells(1, 4) = "Price"
Sheets(1).Cells(1, 5) = "market value"
End Sub
So what this code does, loops for duplicates in Col 1, sums up associated values in col 5 and picks the max associated value in col 4.
Could you use, where you fill a cell and replicate it,
L = LastRow + 1
With Sh.Range("A1:A" & L).Offset(0, 4)
.Cells(1,1).FormulaArray = "=MAX(IF(A$2:A$" & L & "=A1,D$2:D$" & L & "))"
.FillDown
.Value = .Value
End With
Handling A1 vs R1C1 style is easy, with Application.ConvertFormula
Need to be careful about Row/Col Abs/Rel referencing.

Resources