excel - 根据下拉选项在工作簿之间复制和粘贴数据

Question

只是一个快速的，我编写了一段 VBA 代码，用于在两个工作簿之间复制和粘贴数据。但是，我希望能够复制特定数据而不是整个表。所以工作簿“x”我想通过选择工作簿“y”中的下拉框来过滤列“L” - 字段“P14”。

我将如何做到这一点，以便用户选择它过滤并将该数据粘贴到工作簿 y 中。

下面是我到目前为止所做的代码:

Private Sub CommandButton1_Click()

    Dim x As Workbook
    Dim y As Workbook
    Dim p As String

    Set p = y.Worksheets("Title").Cells(14, "P").Value
    Set x = Workbooks.Open("C:\Users\name\Desktop\Project
    Autonetics\CoreData")
    'x.Worksheets("Xero").Range("L1").AutoFilter Field:=1, Criteria:="p"
    With Xero
        .AutoFilterMode = False
        With .Range("L:L")
            .AutoFilter Field:=1, Criteria:="p"
            .SpecialCells (xlCellTypeVisible)
        End With
    End With
    Set y = ThisWorkbook
    x.Worksheets("Xero").Range("A1:L100000").Copy
    Application.DisplayAlerts = False
    y.Worksheets("Costings").Range("A1").PasteSpecial

    x.Close
End Sub

Answer 1

这是您可以使用的东西。我个人不是这样的On Error粉丝，但在使用 SpecialCells 时，在内部检查返回的错误是合法的。 .

Private Sub CommandButton1_Click()

Dim wb1 As Workbook, wb2 As Workbook
Dim sht1 As Worksheet, sht2 As Worksheet
Dim lc As Long, lr As Long
Dim rng As Range, str As String

'Set your two workbooks
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Open("C:\Users\name\Desktop\ProjectAutonetics\CoreData")

'Set your two worksheets
Set sht1 = wb1.Worksheets("Title")
Set sht2 = wb2.Worksheets("Xero")

'Get your criteria ready
str = sht1.Range("P14").Value

'Get your range to filter ready
With sht2
    lr = .Cells(.Rows.Count, 12).End(xlUp).Row
    lc = .Cells(1, .Columns.Count).End(xlToLeft).Column
    Set rng = .Range(.Cells(1, 1), .Cells(lr, lc))
End With

'Apply filter and act if any hits
rng.AutoFilter 12, str
If rng.SpecialCells(12).Cells.Count > rng.Rows(1).Cells.Count Then
    rng.SpecialCells(12).Copy sht1.Cells(1, 1)
End If

'Close your second workbook
wb2.Close False

End Sub

我非常广泛地希望您能清楚地看到这段代码中发生了什么。

祝你好运。