根據下拉選項在工作簿之間復制和粘貼數據

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

我非常廣泛，希望您能清楚地看到這段代碼中發生了什么。

祝你好運。