从数据validation列表中复制并粘贴

我写了下面的代码。 我有3个工作表： Dashboard ， Workings和Data 。 在工作表（ Dashboard ）上有一个数据validation列表，里面有很多公司名单。 我希望能够从列表中select一个公司，然后按下一个button，然后从工作表数据中的公司列表中进行匹配，该工作表数据中包含许多其他列，以便查找该公司的相应数据。 我希望能够从所select的公司获取某些数据，并将其粘贴到工作表（ 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