从数据验证列表中复制并粘贴

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