How to copy column from last column N number of times? - vba

I currently have the following code, which was made by a lovely member here
Sub YearsNumberReduction()
Dim LastCol As Long
Dim DelCnt As Integer
DelCnt = Sheets("Panel").Range("E19").Value
With ThisWorkbook.Sheets("Current")
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
If LastCol >= DelCnt Then
.Range(.Cells(1, LastCol - DelCnt + 1), .Cells(1, LastCol)).EntireColumn.Delete
End If
End With
This code takes the last column, and deletes the column by the number of times specified in E19. How can I change the code, so instead of deleting a specified number of times from the last row, we can add columns instead? Essentially reversing the role of that VBA Macro.
I also have another question. In my Excel solution, I constantly add the number of years and decrease them (those years are business years and each year carries a profit, calculated by revenue-costs). On the main worksheet, I have 10 years. That is the default number of years. However, this does not change when I add or decrease years based on the function I mentioned. The profit for the 10 years is calculated by =SUM(B29:B39). How can I make the range change (e.g if I add one more year, Year 11 will be added and =SUM(B29:40) in the main spreadsheet which gives a profit overview?
Current adding of columns
Worksheets("Sheet1").Range("L1:L15").AutoFill Destination:=Worksheets("Sheet1").Range("L1").Resize(15, Worksheets("Panel").Range("E17") + 1), Type:=xlFillDefault
However, this adds from a fixed column, rather than the last. So I extend columns by 5, it will add 5, but if I extend it by 5 again, it wont extend since it has a fixed point. So I need it to change based on the last column.
EDIT
Year 1 Year 2 Year 3 Year 3 Year 3
Sales 100 115 132 132 152
Costs 30 32 33 33 35
Profit 70 84 99 99 99
Year 3 stays the same, and costs do not update (=C3*1.05) it should rise by 5%

Try the following. Assumes you can use column A to find the last used row:
Sub YearsNumberReduction()
Dim LastCol As Long
Dim DelCnt As Integer
DelCnt = Sheets("Panel").Range("E19").Value
Dim copyCol As Range
Dim DestRange As Range
Dim lastRow As Long
With ThisWorkbook.Sheets("Current")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set copyCol = .Range(.Cells(1, LastCol), .Cells(lastRow, LastCol))
Set DestRange = .Range(.Cells(1, LastCol), .Cells(lastRow, LastCol + DelCnt))
copyCol.AutoFill Destination:= DestRange, Type:=xlFillDefault
End With
End Sub

Related

vba dynamic sum based on dynamic range values

I would like to thank everyone for their feedback so far it has helped a great deal. one question that I am grappling with is how to make my column values even so I can do a dynamic subtototal.
Column k Column R Column Y Column AF Column AM Column AT
1 2 4 2 3 5
3 9 7 8 2 4
2 3 6 3 5 8
3 3 2
5
TOT 9 14 25 13 12 17
Column k Column R Column Y Column AF Column AM Column AT
1 2 4 2 3 5
3 9 7 8 2 4
2 3 6 3 5 8
3 3 2
5
TOT 9 14 25 13 12 17
on a monthly basis the column values can fluctuate, the question is how do I use VBA to create a dynamic sum based on the column with the most values.
Dim Rin As Range
Dim Rout As Range
Dim lRa As Long
lRa = Range("i" & Rows.count).End(xlUp).Row
Set Rin = ws.Range("i" & lRa)
Set Rout = ws.Range("I" & lRa)
aCell.Range("I11:P12", "R12:AY12").Copy
Rout.Offset(2, 0).Resize(1, 28).Formula = "=SUBTOTAL(9," &
Rin.Address(0, 0) & ")"
lR = ws.Range("I" & Rows.count).End(xlUp).Row - 1 ' Finds the last blank
row
ws.Range("I" & lR).PasteSpecial xlPasteFormats
If you know where your data starts you can use a method such as that given by Shai Rado.
You can't have any entirely empty rows or columns in the range.
You can then feed this lastRow variable into the range address for adding your subtotal formula.
Example: If your data is a continuous set of populated columns starting at Cell D3 the following will get the last used row number in the range of columns:
Option Explicit
Public Sub AddSubTotal()
Dim lastRow As Long
Dim lastCol As Long
Dim firstRow As Long
Dim rowHeight As Long
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet2") 'change as appropriate
With ws.Range("D3").CurrentRegion 'change as appropriate
firstRow = .Rows(1).Row
lastRow = .Rows(.Rows.Count).Row
lastCol = .Columns(.Columns.Count).Column
rowHeight = lastRow - firstRow + 1
End With
With ws
.Range(.Cells(lastRow + 1, "D"), .Cells(lastRow + 1, lastCol)).FormulaR1C1 = "=SUBTOTAL(9,R[-" & rowHeight & "]C:R[-1]C)"
End With
End Sub
If you need a different method to find the last used row and last used column there a lots of available resources online including my favourite by Ron De Bruin Find last row, column or last cell. The appropriateness of each method is determined by the shape and properties of your range e.g. no blank columns or rows in range. So choose a method that is right for your data or that can test for different likely cases and apply different methodologies as appropriate.
It is quite difficult to give a definitive answer (and i don't want to code lots of different possible scenarios) to this question without knowing more about the nature and variability of the data. If you familiarise yourself with the methods of finding last row and column you will be able to implement those that suit your needs.

Autofill column across dynamic start

I am trying to write a code to autofill the final column in a worksheet to the right x times.
I have the code which will pick up the last column :
With ActiveSheet
LC = .Cells(3, .Columns.Count).End(xlToLeft).Column
End With
Columns(LC).Select
and also code that would autofill across if I specify which specific columns
Selection.AutoFill Destination:=Columns("BE:BQ"), Type:=xlFillDefault
What I am struggling with is how to replace the columns "BE:BQ" with the required code which is linked to the original Last Column (LC).
Ideally I would like it to autofill across to add, say 10, new columns. Do you have any advice?
Ideally I would like the code to cycle through all the worksheets in my workbook - but this is probably a bit advanced for me!
Thank you very much in advance.
UPDATE
Thank you for your suggested comments. I have amended the code as below. This firstly appeared to work perfectly. However, I have since come across two issues.
Issue 1 - on some sheets when it fills across a date field which is in row 3 does not fill. It just copies across the date exactly the same as the one in the last row (i.e. 01/06/2017 but is displayed as Jun-17). I would like this to fill across a month at a time.
Issue 2 - in row 2 there is a date which is the last day of the pervious month. This is currently entered manually but as I have developed the macro I would like this to be changed to a formula equal to date in the cell below minus 1 day. I tried to do this using the following formula but it went completely awry!
sht.Cells(2, LC).Formula = "=" & Cells(3, LC) & "-1"
Any advice on how to fix these two issues would be most appreciated.
Dim LC As Integer
Dim LR As Long
ActiveSheet.Unprotect
With ActiveSheet
LC = .Cells(3, .Columns.Count).End(xlToLeft).Column
LR = .Cells(Rows.Count, LC).End(xlUp).Row
End With
Range(Cells(1, LC), Cells(LR, LC)).Select
Selection.AutoFill Destination:=Range(Cells(1, LC), Cells(LR, LC + 10)),Type:=xlFillDefault
Try this. I'm not sure about the A2 bit as the code suggests the autofill starts at row 3 but can jus replace 3 with 2 in the code if it should also be included.
Sub x()
Dim LC As Long, LR As Long, ws As Worksheet
For Each ws In Worksheets
With ws
LC = .Cells(3, .Columns.Count).End(xlToLeft).Column
LR = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.Cells(3, LC), .Cells(LR, LC)).AutoFill Destination:=.Range(.Cells(3, LC), .Cells(LR, LC + 10)), Type:=xlFillDefault
.Cells(3, LC).AutoFill Destination:=.Cells(3, LC).Resize(, 10), Type:=xlFillMonths
.Range("A2").Formula = "=A3-1"
End With
Next ws
End Sub

Copy Pasting Range of different length using VBA

http://i.stack.imgur.com/93bt7.png
Hi,
I am trying to work with a code I have made but am having some trouble.
If you look at my photo above, in cell B3 I have a CUSIP. What I want to do is copy that CUSIP and paste it in each row of info for that CUSIP (so rows A4 till A8). Then I want to move to the second CUSIP in J3 (the CUSIPS are all in row 3 and 8 columns apart) and then paste the CUSIP in rows J4 to J35.
I want to keep doing this over and over for 1000 securities but the issue is that the rows differ in length.
My code is working until I get to the last piece of code which I have put in as a comment. It works but is static. Only works for moving from the 1st to 2nd security then fails. I am trying to think of a dynamic way for me to move from the cell which the CUSIP is last pasted in to the third row and corresponding column everytime (column will be 9 apart every time from the last pasted cell).
Here it is:
Sub CUSIP_Copy_Paste()
Dim LastRow As Long
Dim LastCol As Long
Dim c As Long
Dim r As Long
Range("B3").Select
LastCol = Cells(4, Columns.Count).End(xlToLeft).column
For c = 2 To LastCol Step 8
LastRow = Cells(Rows.Count, c).End(xlUp).row
ActiveCell.Copy
Cells(4, ActiveCell.Offset(1, -1).column).PasteSpecial xlPasteValues
For r = 5 To LastRow
Cells(r, ActiveCell.Offset(1, 0).column).PasteSpecial xlPasteValues
Next r
''''''ActiveCell.Offset(-5, 9).Select
Next c
End Sub
Thanks!
Your error lies in the final offset. Instead of -5, put in a variable, preferrably the variable which is the difference between the end of the rows count and the beginning, which is always 3.
That is to say, Offset(3 - lastRow, 9)
You almost had it friendo :)

Delete a range of columns using two named ranges

I need to delete a range of rows using two named ranges
Current find the column numbers for the last column (lastColumn) and then the column 6 spots behind it (colrange)
Dim lastColumn As Integer
With ActiveSheet
lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
colrange = lastColumn - 6
I want to delete the columns in the range colrange:lastColumn but not sure how to do this?
Range(Cells(1,colRange),Cells(1,lastColumn)).EntireColumn.Delete
you can simply use:
Range(Columns(colRange),Columns(lastColumn)).Delete
or directly:
With ActiveSheet
.Range(.Columns(.Cells(1, .Columns.Count).End(xlToLeft).Column - 6), .Columns(.Cells(1, .Columns.Count).End(xlToLeft).Column)).Delete
End With

Finding range of consecutive rows in Excel that yields the highest average sum

I have an Excel spreadsheet that can contain anything from 10 to 200 rows. I want to cycle through all combinations of ranges (of three rows or more) to find the range of rows that yields the highest average.
For example, if my rows are:
12
1
4
18
9
3
... then starting with the A1:A3, then A1:A4 through to A1:A6, then moving on to A2:A4, then A2:A5, and so on, until all combinations of ranges of three rows or more have been Averaged. I would then like to either highlight, or even MsgBox the range with the highest average.
I know this is relatively simple, but it is really hurting my head. The 'winner' in the above scenario would be A3:A5 with 10.333, though I will stress that the range does not have to be 3 rows.
This will do it:
Sub bp()
Dim avg As Double
Dim rng As Range
Dim ws As Worksheet
Dim i&, t&
Dim avgAdd As String
Set ws = ActiveSheet
With ws
Set rng = .Range(.Cells(1, 1), .Cells(1, 1).End(xlDown))
For i = 1 To rng.Rows.count - 2
For t = i + 2 To rng.Rows.count
If WorksheetFunction.Average(.Range(.Cells(i, 1), .Cells(t, 1))) > avg Then
avg = WorksheetFunction.Average(.Range(.Cells(i, 1), .Cells(t, 1)))
avgAdd = .Range(.Cells(i, 1), .Cells(t, 1)).Address
End If
Next
Next
MsgBox avgAdd & ":" & avg
End With
End Sub
I added a debug print every time that the average is larger.