Copying from active cell

[chadski778]

I would like a macro for copying the contents of an active cell and pasting into 100 cells immediately below the active cell in the same column, if that is possible?

 

[njimack]

ActiveCell.Offset(100, 0) = ActiveCell

 

[chadski778]

Sorry I meant pasting into every cell up to the last occupied row of the Active cell column

 

[njimack]

Sorry I meant pasting into every cell up to the last occupied row of the Active cell column

Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(100, 0)) = ActiveCell

 

[Sthrncali]

Another Option:

ActiveCell.Resize(100, 1).Value = ActiveCell.Value

 

[chadski778]

That works great thanks. Could this be modified to include pasting all the way to the last occupied row in the spreadsheet?

 

[Sthrncali]

Sub CopyDown()
Dim myRow As Integer
Dim LastRow As Integer
Dim NewRows As Integer

myRow = ActiveCell.Row
LastRow = ActiveCell.End(xlDown).Row
NewRows = (LastRow - myRow) + 1
ActiveCell.Resize(NewRows, 1).Value = ActiveCell.Value
End Sub

If there are any blanks in your Col, it will break this.. Meaning

Col A

15
14
18
19
20

18

In that example, the code would only copy down to the row with 20. If you need it to skip blanks and find the absolute last row with data, regardless of any blanks in between...

Sub CopyDown()
Dim myRow As Integer
Dim LastRow As Integer
Dim NewRows As Integer
myRow = ActiveCell.Row
LastRow = ActiveSheet.Cells(65536, ActiveCell.Column).End(xlUp).Row
NewRows = (LastRow - myRow) + 1
ActiveCell.Resize(NewRows, 1).Value = ActiveCell.Value
End Sub

 

[chadski778]

That works if there is data in the column under the Active Cell but not if there are blank cells in the same column and occupied cells in another column. Sometimes I will have an actice cell with a column of blanks underneath. I need to fill these up to the last occupied row in the sheet eg active cell D1, data present in A1:A10000. Fill D2:D10000 with contents of active cell. (A1:A10000 is just arbitrary as an example)

 

[Sthrncali]

Sub CopyDown()
Dim myRow As Integer
Dim LastRow As Integer
Dim NewRows As Integer

myRow = ActiveCell.Row
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
NewRows = (LastRow - myRow) + 1
ActiveCell.Resize(NewRows, 1).Value = ActiveCell.Value
End Sub

This change will find the last used row, regardless of what column it's in.