仅复制和粘贴范围内使用的单元格答案

【问题标题】：Copy and paste only used cells in range仅复制和粘贴范围内使用的单元格
【发布时间】：2017-10-12 12:21:09
【问题描述】：

非常感谢您的帮助。我有两个打开的工作簿，一个用于计算，第二个用于保存记录。我曾经手动做所有事情，但后来我发现了宏和 VBA，但我是初学者。我已经设法编写了一个适合我的代码，但我希望对其进行改进。

我设置了一个范围 Y22:Y37（工作表在两个工作簿中具有相同的名称），它并不总是完全填充值，但我不知道如何更改代码以仅复制范围中使用的单元格。我尝试使用 SkipBlanks:=True，但没有成功。

一旦我复制了激活第二个工作簿的范围，找到第一个空行并将转置的值粘贴到那里（故意从 B 列开始）。但同样，我粘贴了整个 Y22:Y37 范围，我认为这是不必要的。另外，我希望在粘贴后使用的单元格下方有一个底部边框。在图片中，您可以看到同时我设法制作了底部边框，但我使用了整行。

我以某种方式调整了我能找到的各种代码的需要，但我知道我可能使用了代码的许多冗余部分，但我希望有人可以帮助我使其更简洁。非常感谢您，即使您阅读了这么远。工作簿的图片在下面的链接中。

Sub CopyVyuctovani()
Set TargetWB = Workbooks("Výdej.xlsm")
Set SourceWB = Workbooks("DPV.xlsm")
TargetSH = ActiveSheet.Name
SourceWB.Sheets(TargetSH).Range("Y22:Y37").Copy
TargetWB.Sheets(TargetSH).Activate
lMaxRows = Cells(Rows.Count, "B").End(xlUp).Row
Range("B" & lMaxRows + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Range("A" & lMaxRows + 1).Value = SourceWB.Sheets("Souhrn").Range("E30").Value
Application.CutCopyMode = False
Range("A" & Rows.Count).End(xlUp).EntireRow.Font.Color = RGB(255, 0, 0)
Range("A" & Rows.Count).End(xlUp).EntireRow.Borders(xlEdgeBottom).LineStyle = xlContinuous
End Sub

Source Workbook

Target Workbook

【问题讨论】：

对于初学者，您应该完全限定这样的引用：lMaxRows = Cells(Rows.Count, "B").End(xlUp).Row 并确保使用 Option Explicit，这将强制您声明所有变量。
总是复制整个范围可能更有效。这 16 个单元格可以在一行代码中复制。确定要包含/排除哪些单元格将需要至少一个额外的步骤。在处理如此低的数量时，不值得付出努力。也就是说，您可以通过将 intersect function 与 used range object 结合使用来实现。
你是对的，也许这真的不值得努力，它真的是低容量的数据。我一定会记得声明所有变量，正如我所说，我很高兴让代码以某种方式工作。谢谢

标签： excel vba

【解决方案1】：

代码或多或少相同，但它会解决您的两个问题

Sub CopyVyuctovani()

    Dim targetWB As Workbook
    Dim sourceWb As Workbook
    Dim targetSH As String
    Dim lmaxrows As Long

    Set targetWB = Workbooks("Výdej.xlsm")
    Set sourceWb = Workbooks("DPV.xlsm")
    targetSH = ActiveSheet.Name

    sourceWb.Sheets(targetSH).Range("Y22:Y37").Copy

    With targetWB.Sheets(targetSH)
        lmaxrows = Cells(Rows.Count, "B").End(xlUp).Row
        .Range("B" & lmaxrows + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=True
        .Range("A" & lmaxrows + 1).Value = sourceWb.Sheets("Souhrn").Range("E30").Value
        Application.CutCopyMode = False
        .Range("A" & lmaxrows & ":Q" & lmaxrows).Font.Color = RGB(255, 0, 0)
        .Range("A" & lmaxrows & ":Q" & lmaxrows).Borders(xlEdgeBottom).LineStyle = xlContinuous
    End With

End Sub

【讨论】：

感谢您的回答，这看起来好多了。但我收到一个错误：需要运行时错误“424”对象。当我单击 Debug 时，此行突出显示： Set targetSH = ActiveSheet.Name
@Tireur 我犯了一个小错误，现在我已经纠正了。再试一次。

【解决方案2】：

@伊姆兰·马雷克

谢谢你，有了这个我没有错误，太棒了:) 但是不知何故，复制的范围被粘贴到目标 WB 的第 38 行（也许它使用源 wb 中的最后一行 37？）所以我尝试激活首先瞄准WB，它似乎有效。然后我在格式化时遇到了问题，您的代码在粘贴的行上方使用了格式。所以我在 1maxrows 中添加了 +1，现在看起来不错。代码现在看起来像这样。

Sub CopyVyuctovani()

Dim targetWB As Workbook
Dim sourceWb As Workbook
Dim targetSH As String
Dim lmaxrows As Long

Set targetWB = Workbooks("Výdej.xlsm")
Set sourceWb = Workbooks("DPV.xlsm")
targetSH = ActiveSheet.Name

sourceWb.Sheets(targetSH).Range("Y22:Y37").Copy

With targetWB.Sheets(targetSH)
    .Activate
    lmaxrows = Cells(Rows.Count, "B").End(xlUp).Row
    .Range("B" & lmaxrows + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=True
    .Range("A" & lmaxrows + 1).Value = sourceWb.Sheets("Souhrn").Range("E30").Value
    Application.CutCopyMode = False
    .Range("A" & lmaxrows + 1 & ":Q" & lmaxrows + 1).Font.Color = RGB(255, 0, 0)
    .Range("A" & lmaxrows + 1 & ":Q" & lmaxrows + 1).Borders(xlEdgeBottom).LineStyle = xlContinuous
End With
End Sub

【讨论】：