只复制和粘贴范围内使用的单元格

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

来源

2017-10-12 Tireur

首先，你应该完全限定这样的引用：'lMaxRows =细胞（Rows.Count， “B”）结束（xlUp）.Row'一个确保使用'选项Explicit'这将迫使你要声明所有的变量。 – braX

总是复制整个范围可能更高效。这16个单元可以复制在一行代码中。确定要包含/排除哪些单元需要至少一个附加步骤。处理这么低的数量时，这是不值得的。这就是说你可以通过将[相交函数]（https://msdn.microsoft.com/en-us/vba/excel-vba/articles/application-intersect-method-excel）与[使用范围对象]（https://msdn.microsoft.com/en-us/vba/excel-vba/articles/worksheet-usedrange-property-excel）。 –

你是对的，也许它真的不值得一个努力，这是真正的低数据量。正如我所说，我将确定要记住声明所有变量，我只是很高兴让代码以某种方式工作。谢谢 – Tireur

@Imran马利克

谢谢你，用这一个我得到没有错误，很棒:)但不知何故，复制的范围被粘贴到目标WB的第38行（也许它使用源wb中的最后一行37），所以我试图首先激活目标WB，它似乎工作。然后我遇到了一个格式问题，在你的代码中，格式被用在一个恰好高于粘贴的行上。所以我给+1增加了+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

来源

2017-10-13 08:26:49 Tireur

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

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

来源

2017-10-12 12:57:27

谢谢你的回答，这看起来好多了。但是我得到一个错误：运行时错误'424'对象需要。当我点击调试时，这一行高亮显示： Set targetSH = ActiveSheet.Name – Tireur

@Tireur我犯了一个小错误，我现在已经纠正了。再给它一次。 –

只复制和粘贴范围内使用的单元格

回答

相关问题