Question

我真的很感激一点帮助。我有两个打开的工作簿，一个用于计算，第二个用于保存记录。我曾经手动完成所有事情，但之后我发现了宏和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

Answer 1

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

<configuration>

Answer 2

@Imran Malek

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

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

复制并粘贴范围

2 个答案: