如何向下复制单元格而不覆盖它下面的内容？

Question

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

如果您无法查看Dropbox，则这是工作表。

这是工作簿。我要做的是它显示3M的地方，将公司的名称复制到A列中显示Total的位置，并对下一家公司做同样的事情。

如何在Excel VBA中执行此操作？我知道我可以使用最后一行，但这并不是我认为的最佳方式，因为原始版本将有超过300家不同的公司。

这是我现在使用的原始代码。没有添加额外的位。

选项明确

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

Answer 1

马特，几个月前我有一个很好的功能，但我忘了复制到我的图书馆。但是，我做了一个很好的模拟我之前的事情。 （我出于某种原因使用它来填充数据透视表中的条目。）

无论如何，这里是。您可能需要对其进行调整以满足您的确切需求，我并不是说它目前不容易出现任何错误，但它应该是一个很好的开始。

编辑 =我已更新我的代码帖子以集成到您的代码中，以便您更轻松。

    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

Answer 2

只要没有公式，你就不想覆盖......

编辑 - 更新为根据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