只複製和粘貼範圍內使用的單元格

我真的很感激一點幫助。我有兩個開放的工作簿，一個用於計算，第二個用於保存記錄。我曾經手動做過所有事情，但後來我發現了宏和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我犯了一個小錯誤，我現在已經糾正了。再給它一次。 –

只複製和粘貼範圍內使用的單元格

回答

相關問題