从数据验证列表复制和粘贴

Question

我写了下面的代码。 我有3个工作表： Dashboard ， Workings和Data 。 我在工作表（ Dashboard ）上有一个数据验证列表，其中有很多公司。 我希望能够从列表中选择一家公司，按一个按钮，然后从工作表数据中的公司列表中进行匹配，该工作表数据中有很多其他列用于该公司的相应数据。 我希望能够从选定的公司中获取某些数据，并将其粘贴到工作表中的下一个可用行（ Workings ）。 工作表（数据）中的列表具有同一公司的多个条目，因此，为什么在这里添加循环。

此代码不会产生错误，但不会产生任何结果。

有人可以告诉我我要去哪里了吗

非常感谢。

Sub pull_data()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Application.EnableCancelKey = xlDisabled

CompanyListLocation = Worksheets("Dashboard").Cells(2, 4).Value
'Company = Worksheets("Data").Cells(CompanyListLocation, 1).Value

For x = 2 To 1000000

If Worksheets("Data").Cells(x, 5).Value = CompanyListLocation Then

Worksheets("Data").Cells(x, 5).Copy
Worksheets("Workings").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Worksheets("Data").Cells(x, 14).Copy
Worksheets("Workings").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Worksheets("Data").Cells(x, 15).Copy
Worksheets("Workings").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues


End If

Next x

End Sub

Answer 1

您是否要复制工作表A列中数据表中的所有数据？

您可以尝试以下类似方法。 根据需要进行调整。

Sub CopyData()
Dim wsCriteria As Worksheet, wsData As Worksheet, wsDest As Worksheet
Dim CompanyListLocation
Dim lr As Long, dlr As Long
Application.ScreenUpdating = False
Set wsCriteria = Sheets("Dashboard")
Set wsData = Sheets("Data")
Set wsDest = Sheets("Workings")
CompanyListLocation = wsCriteria.Range("D2").Value
lr = wsData.UsedRange.Rows.Count
dlr = wsDest.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsData.AutoFilterMode = False
With wsData.Rows(1)
    .AutoFilter field:=5, Criteria1:=CompanyListLocation
    If wsData.Range("E1:E" & lr).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
        wsData.Range("E2:E" & lr).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("A" & Rows.Count).End(3)(2)
        wsData.Range("N2:N" & lr).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("A" & Rows.Count).End(3)(2)
        wsData.Range("O2:O" & lr).SpecialCells(xlCellTypeVisible).Copy wsDest.Range("A" & Rows.Count).End(3)(2)
    End If
    .AutoFilter
End With
Application.ScreenUpdating = True
End Sub

如果只想复制值，请将复制粘贴代码更改为此。

If wsData.Range("E1:E" & lr).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
    wsData.Range("E2:E" & lr).SpecialCells(xlCellTypeVisible).Copy
    wsDest.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
    wsData.Range("N2:N" & lr).SpecialCells(xlCellTypeVisible).Copy
    wsDest.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
    wsData.Range("O2:O" & lr).SpecialCells(xlCellTypeVisible).Copy
    wsDest.Range("A" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
End If