复制和合并列值

Question

我有一个代码，用于从数据透视表复制/粘贴值并将其输出到另一个工作表中。一切输出正常，但我希望将数据透视表的前两列合并，然后输出到自己的列中。我不确定该如何开始

Sub InsertData()

Dim wsCopy As Worksheet, wsDest As Worksheet
Dim DefCopyLastRow As Long, DefDestLastRow As Long


'Set variables for copy and destination sheets
Set wsCopy = Workbooks("Warranty Template.xlsm").Worksheets("PivotTable")
Set wsDest = Workbooks("QA Matrix template.xlsm").Worksheets("Plant Sheet")

'1. Find last used row in the copy range based on data in column A
DefCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, 1).End(xlUp).Offset(-1, 0).Row



'2. Find first blank row in the destination range based on data in column D
'Offset property moves down 1 row
DefDestLastRow = wsDest.Cells(wsDest.Rows.Count, 10).End(xlUp).Offset(1, 0).Row



'3. Copy & Paste Data For Each Filter Selection

'Backhoes
With ActiveWorkbook.SlicerCaches("Slicer_Model_Family_Description")
        .SlicerItems("Backhoes Case Burlington").Selected = True
        .SlicerItems("CE Tractor Loader Burlington").Selected = False
        .SlicerItems("Corn Headers Burlington").Selected = False
        .SlicerItems("Dozer Case Calhoun Burlington").Selected = False
        .SlicerItems("Draper & Pickup Headers Burlington").Selected = False
        .SlicerItems("Forklift Case Burlington").Selected = False
        .SlicerItems("Grain Headers Burlington").Selected = False
        If .SlicerItems("Backhoes Case Burlington").Selected Then

'1. Find last used row in the copy range based on data in column A
DefCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, 1).End(xlUp).Offset(-1, 0).Row



'2. Find first blank row in the destination range based on data in column D
'Offset property moves down 1 row
DefDestLastRow = wsDest.Cells(wsDest.Rows.Count, 10).End(xlUp).Offset(1, 0).Row

'3. Copy and Paste Data
[INSERT COLUMN A & B COMBINED OUTPUTTED TO COLUMN D]

wsCopy.Range("D5:D" & DefCopyLastRow).Copy
wsDest.Range("P" & DefDestLastRow).PasteSpecial Paste:=xlPasteValues

wsCopy.Range("E5:E" & DefCopyLastRow).Copy
wsDest.Range("S" & DefDestLastRow).PasteSpecial Paste:=xlPasteValues

NewLastRow = wsDest.Cells(wsDest.Rows.Count, 10).End(xlUp).Row
wsDest.Range("AG" & DefDestLastRow & ":AG" & NewLastRow).Value = "Final Customer"

wsDest.Range("D" & DefDestLastRow & ":D" & NewLastRow).Value = "TLB"


End If
End With
End Sub

Answer 1

您可以执行以下操作：

Dim r

r = wsCopy.Evaluate("=A5:A" & DefCopyLastRow & " & B5:B" & DefCopyLastRow)
wsDest.Range("D" & DefDestLastRow).Resize(UBound(r, 1), 1).Value = r

Evaluate（在这种情况下）将产生一个二维数组（1到＃rows，1到#cols）