CODEWITHSUNDEEP
excelvba
Matt Ridge
Matt Ridge

Reputation: 3651

How to copy cells downwards without overwriting what's under it?

https://dl.dropbox.com/u/3327208/Excel/copydown.xlsx

This is the sheet if you can't view dropbox. enter image description here

This is the workbook. What I'm looking to do is where it shows 3M, copy the title of the company down to where it shows Total in Column A, and do the same with the next company.

How do I do this in Excel VBA? I know I can use the last row, but it's not exactly the best way for this I believe, because the original version will have over 300 different companies.

Here is the original code I am using for now. Without the extra bits added in.

Option Explicit

Sub Import()

    Dim lastrow As Long
    Dim wsIMP As Worksheet 'Import
    Dim wsTOT As Worksheet 'Total
    Dim wsSHI As Worksheet 'Shipped
    Dim wsEST As Worksheet 'Estimate
    Dim wsISS As Worksheet 'Issued
    Dim Shift As Range


    Set wsIMP = Sheets("Import")
    Set wsTOT = Sheets("Total")
    Set wsSHI = Sheets("Shipped")
    Set wsEST = Sheets("Estimate")
    Set wsISS = Sheets("Issued")

    With wsIMP

        wsIMP.Range("E6").Cut wsIMP.Range("E5")
        wsIMP.Range("B7:G7").Delete xlShiftUp

End Sub

Upvotes: 0

Views: 1070

Answers (2)

Tim Williams
Tim Williams

Reputation: 166316

As long as there are no formulas you don't want to overwrite...

EDIT - updated to set original range based off end of column B

Sub Macro1()
    Dim sht as WorkSheet

    Set sht = ActiveSheet

    With sht.Range(sht.Range("A7"), _
                   sht.Cells(Rows.Count, 2).End(xlUp).Offset(0, -1))

        .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
        .Value = .Value

    End With    
End Sub

Upvotes: 1

Scott Holtzman
Scott Holtzman

Reputation: 27249

Matt, I had a great function for this a few months back, but I forgot to copy into my library. However, I've done a pretty good mock-up of what I had before. (I was using it to fill down entries in a pivot table for some reason or other).

Anyway, here it is. You may need to tweak it to meet your exact needs, and I am not claiming it's not prone to any errors at the moment, but it should be a great start.

EDIT = I've updated my code post to integrate into yours to make it easier for you. 

    Sub Import()

    Dim lastrow As Long
    Dim wsIMP As Worksheet, wsTOT As Worksheet 'Total
    Dim wsSHI As Worksheet, wsEST As Worksheet 'Estimate
    Dim wsISS As Worksheet, Shift As Range


    Set wsIMP = Sheets("Import")
    Set wsTOT = Sheets("Total")
    Set wsSHI = Sheets("Shipped")
    Set wsEST = Sheets("Estimate")
    Set wsISS = Sheets("Issued")

    With wsIMP

        .Range("E6").Cut .Range("E5")
        .Range("B7:G7").Delete xlShiftUp

        Call FillDown(.Range("A1"), "B")

        '-> more code here

    End With


End Sub

Sub FillDown(begRng As Range, col As String)

Dim rowLast As Long, rngStart As Range, rngEnd As Range

rowLast = Range(col & Rows.Count).End(xlUp).Row
Set rngStart = begRng

Do

    If rngStart.End(xlDown).Row < rowLast Then
        Set rngEnd = rngStart.End(xlDown).Offset(-1)
    Else
        Set rngEnd = Cells(rowLast, rngStart.Column)
    End If

    Range(rngStart, rngEnd).FillDown
    Set rngStart = rngStart.End(xlDown)

Loop Until rngStart.Row = rowLast


End Sub

enter code here

Upvotes: 1

Related Questions