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

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.

Related

How to copy ranges from several sheets to one sheet

I want to copy ranges from several worksheets to one sheet.
The range to copy is C3 to the last row of data.
I need to paste it into a column on the main sheet in B6, then repeat the process on the next sheet (from C3 again) into the next column C6 and so on to column J.
I tried:
Set WkSh = ActiveSheet
Set DatShs = Sheets(Array("E0303_0", "E0304", "E0305", "E0306", "E0307", "E0308", "E0309", "E0310", "E0311_0"))
Set DatSh = Sheets(DatSh) 'I get Run time Error '13' Type mismatch here
Set Lrow = DatSh.Cells(Rows.Count, "C").End(xlUp)
TnD = DatSh.Range("C:B").Find("*", , , , xlByRows, xlPrevious).Row
Set RngGrp = DatSh.Range("TnD", Lrow)
Sheets("E0303_0").Range(RngGrp).Copy
ActiveWorkbook.WkSh.Range("A6").Paste
ActiveWorkbook.Sheets("E0304").Range("C3" & Lrow).Copy
ActiveWorkbook.WkSh.Range("C6").Paste
ActiveWorkbook.Sheets("E0305").Range("C3" & Lrow).Copy
ActiveWorkbook.WkSh.Range("D6").Paste
ActiveWorkbook.Sheets("E0306").Range("C3" & Lrow).Copy
ActiveWorkbook.WkSh.Range("E6").Paste
ActiveWorkbook.Sheets("E0307").Range("C3" & Lrow).Copy
ActiveWorkbook.WkSh.Range("F6").Paste
ActiveWorkbook.Sheets("E0308").Range("C3" & Lrow).Copy
ActiveWorkbook.WkSh.Range("G6").Paste
ActiveWorkbook.Sheets("E0309").Range("C3" & Lrow).Copy
ActiveWorkbook.WkSh.Range("H6").Paste
ActiveWorkbook.Sheets("E0310").Range("C3" & Lrow).Copy
ActiveWorkbook.WkSh.Range("I6").Paste
ActiveWorkbook.Sheets("E0311_0").Range("C3" & Lrow).Copy
ActiveWorkbook.WkSh.Range("J6").Paste
Your code makes no sense after the first 2 lines. You are trying to set a sheet to itself Set DatSh. What you want to do is loop through the array. Your lastrow is not a row number, but a range and you are trying to add to a cell. The following is the logic you want to use, you can modify as needed.
Sub test()
Dim SheetArray As Variant
Set SheetArray = Sheets(Array("E0303_0", "E0304", "E0305", "E0306", "E0307", "E0308", "E0309", "E0310", "E0311_0"))
For i = 1 To SheetArray.Count
LR = Sheets(i).Cells(Rows.Count, 3).End(xlUp).Row
Sheets(i).Range(Sheets(i).Cells(3, 3), Sheets(i).Cells(LR, 3)).Copy
ActiveSheet.Cells(i, 6).Paste
Next i
End Sub

Sorting rows in a range with specific background colour in Excel using vba

I'm trying to sort a range of rows in an Excel sheet which all start with a specific green background colour in the first column, but my vba code does not do it at all and I can't see why. The objective is as an example to get from this:
to this:
Private Sub Sort_Click()
Dim StartRow, EndRow, i As Integer
Dim row As Range, cell As Range
'Discover the data starting and end rows
i = 1
StartRow = 1
EndRow = 1
'Check the first cell of each row for the start of background colour
For Each row In ActiveSheet.UsedRange.Rows
Set cell = Cells(row.row, 1)
If i < 3 Then
If Hex(cell.Interior.Color) = "47AD70" And i = 1 Then
StartRow = row.row
i = 2
ElseIf Hex(cell.Interior.Color) <> "47AD70" And i = 2 Then
EndRow = row.row - 1
i = 3
End If
End If
Next row
'Sort the range
Range("A" & StartRow & ":" & "A" & EndRow).Sort Key1:=Range("A" & StartRow & ":" & "A" & EndRow), Order1:=xlAscending, Header:=xlNo
End Sub
The code should check the first cell of each row in Column "A" until it reaches the first green backgroend colour where it assigns that row number to the variable StartRow. The loop continues until it no longer detects the green background colour in the first cell. It then assigns that row number - 1 to the variable EndRow. At the end, it sorts the green range numerically using StartRow and EndRow as the range.
Possibly, The Range statement part is not working correctly. I wonder if someone could help with a resolution or a better code all together. The images demonstrate the rows in the green range sorted manually. Thanks in advance
You need to use last parameter of Find method SearchFormat. Set it to whatever format you need:
Sub FGG()
Dim rng As Range, rngStart As Range, rngEnd As Range
'// Clear previous format, if any
Application.FindFormat.Clear
'// Set search format
Application.FindFormat.Interior.Color = Hex("47AD70")
'// Find first cell with format
Set rngStart = Range("A:A").Find(What:="*", SearchFormat:=True)
'// Find last cell with format by using xlPrevious
Set rngEnd = Range("A:A").Find(What:="*", SearchDirection:=xlPrevious, SearchFormat:=True)
'// Define final range
Set rng = Range(rngStart, rngEnd)
'// Sort range and say that that the range has no header
rng.Sort Key1:=rng(1), Header:=xlNo
End Sub
Well, I may have been a bit silly on this issue here, however after some more reading it turned out that to sort complete rows rather than column A only, all I simply had to do was to actually specify whole rows rather than a single column, in the sorting part of the code!
And that is dpne by replacing the line:
Range("A" & StartRow & ":" & "A" & EndRow).Sort Key1:=Range("A" & StartRow & ":" & "A" & EndRow), Order1:=xlAscending, Header:=xlNo
with:
Range("A" & StartRow & ":" & "D" & EndRow).Sort Key1:=Range("A" & StartRow & ":" & "A" & EndRow), Order1:=xlAscending, Header:=xlNo
All that's happened above is that the "A" in the range section has changed to "D" to cover all used columns for sorting the rows.

Excel VBA is Finding Every Other Cell not Every Cell From Method

Excel VBA is finding every other cell using a method to check for Empty Cells. On the next time running the same macro, it then finds the cell that it skipped over on the last run while again skipping the next instance of an empty cell. If I cycle through the macro a few times, eventually every row without data is getting deleted, as per the purpose of the macro. The rows do shift upward upon deletion of the row one at a time, I will try a Union and delete the Range as stated by #BigBen
When a cell that is empty is found, it checks columns A, B, and D to see if formula is applied, and if a formula exists in that row, the entire row gets deleted.
Dim cel, dataCells As Range
Dim rngBlank, dc As Range
Dim lastRow, cForm, c, blnkRange As String
Dim cycleTimes As Integer
On Error Resume Next
Set dataCells = Range("F2:W2").Cells 'This is header of the table of data
cycleTimes = dataCells.Count 'Number of times to cycle through macro
For Count = 1 To cycleTimes 'I don't want to cycle through macro
lastRow = Range("N" & Rows.Count).End(xlUp).Row 'To find end of column
For Each dc In dataCells
c = Split(Cells(1, dc.Column).Address, "$")(1) 'Column Letter
blnkRange = c & "3:" & c & lastRow 'Range to look over for empty cells
Set rngBlank = Range(blnkRange).SpecialCells(xlCellTypeBlanks).Cells
For Each cel In rngBlank '**Skipping Every other Row**
If Not TypeName(cel) = "Empty" Then
cForm = "A" & cel.Row & ",B" & cel.Row & ",D" & cel.Row 'Formula check
If Range(cForm).HasFormula Then
cel.EntireRow.Delete
End If
End If
Next
Next
Next
I was able to use Intersect to find the rows that matched the criteria I was searching for and delete the EntireRow even though the Selection was in separate Rows.
Set dataCells = Range("F2:W2").Cells
lastRow = Range("N" & Rows.Count).End(xlUp).Row 'To find last row to generate range to look through
For Each dc In dataCells 'Have to perform delete row for every column
c = Split(Cells(1, dc.Column).Address, "$")(1)
blnkRange = c & "3:" & c & lastRow
Set rngBlank = Range(blnkRange).SpecialCells(xlCellTypeBlanks).EntireRow
strFormula = "A2:A" & lastRow & ",B2:B" & lastRow & ",C2:C" & lastRow
Set rngFormula = Range(strFormula).SpecialCells(xlCellTypeFormulas)
Intersect(rngFormula, rngBlank).EntireRow.Delete (xlShiftUp) '**THIS helped in deleting Rows**
Next

How to use variables in a VBA code using the sumif function

I download a data set that always has a different number of rows. I store two columns as variables, the imports and the months. Then I need to run a Sumif formula that sums the value of imports by the months. I am writing a Sumif formula that uses the two variables and references the cell to its left.
The cells however vary in location based on the changing size of the data set. So I write a code to select the last active cell on a column and select the cell 3 rows down.
When writing the formula with the variables and the cell its giving me an error. Please help sorry for any typos fist time doing this.
I select all the active cells in range D and store them as months, I do the same for the imports. Then using range I find the last active cell on column M, and use select the cell 3 rows down, where I wish to write my formula.
Please see my codes to see what am I doing wrong, I am a novice coder.
Sub Importaciones()
'
' Importaciones Macro
'
Dim LastRow As Long
LastRow = Range("L" & Rows.Count).End(xlUp).Row
Dim Months As Long
Months = Range("D2", Range("D2").End(xlDown)).Select
Dim Imports As Long
Imports = Range("M2", Range("M2").End(xlDown)).Select
Dim LastRowM As Long
LastRowM = Range("M" & Rows.Count).End(xlUp).Row
Range("M" & LastRowM + 3).Formula = "=sumif(" & Months & ", " &
Range("L" & LastRow + 3) & ", " & Imports & ")"
End Sub
For the formula to work and the sum of the month that I choose comes up
As per all the comments:
Sub Importaciones()
With Worksheets("Sheet1") 'Change to your sheet
Dim LastRow As Long
LastRow = .Range("L" & .Rows.Count).End(xlUp).Row
Dim Months As Range
Set Months = .Range("D2", .Range("D2").End(xlDown))
Dim Imports As Range
Set Imports = .Range("M2", .Range("M2").End(xlDown))
Dim LastRowM As Long
LastRowM = .Range("M" & .Rows.Count).End(xlUp).Row
.Range("M" & LastRowM + 3).Formula = "=sumif(" & Months.Address(0, 0) & ", " & .Range("L" & LastRow + 3).Address(0, 0) & ", " & Imports.Address(0, 0) & ")"
End With
End Sub

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

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).

Resources