Question

我有这个代码，我试图让它在复制信息时添加一行。我遇到的问题是它在它们之间增加了一条线并扰乱了信息。我有一个模板工作表，底部有一个总计，基本上希望它在线条被消耗时向下推。

任何帮助都会很棒

Sub SummurizeSheets()
Dim ws As Worksheet, wsSummary As Worksheet
Dim c As Range

Range("A4:D31").Select
Selection.ClearContents

Application.ScreenUpdating = False
Set wsSummary = Sheets("Summary")
' Set destination cell
Set c = wsSummary.Range("A4")

For Each ws In Worksheets
    If ws.Name <> "Summary" Then
        ActiveCell.EntireRow.Insert
        ws.Range("D1").Copy
        c.PasteSpecial (xlPasteValues)
        ws.Range("E4").Copy
        c.Offset(0, 1).PasteSpecial (xlPasteValues)
        ws.Range("J39").Copy
        c.Offset(0, 2).PasteSpecial (xlPasteValues)
        ' Move destination cell one row down
        Set c = c.Offset(1, 0)
    End If
Next ws
Application.ScreenUpdating = True
End Sub

Answer 1

然后试试这个：

Sub SummurizeSheets()
Dim ws As Worksheet, wsSummary As Worksheet
Dim c As Range

Application.ScreenUpdating = False
Set wsSummary = Sheets("Summary")
Set c = wsSummary.Range("$A$4")

For Each ws In Worksheets
    If ws.Name <> "Summary" Then
        c.EntireRow.Insert xlDown, xlFormatFromLeftOrAbove
        Set c = c.Offset(-1, 0)
        ws.Range("D1").Copy
        c.PasteSpecial xlPasteValues
        ws.Range("E4").Copy
        c.Offset(0, 1).PasteSpecial xlPasteValues
        ws.Range("J39").Copy
        c.Offset(0, 2).PasteSpecial xlPasteValues
    End If
Next ws
Application.ScreenUpdating = True
End Sub

使用宏将行添加到Excel中

1 个答案: