在一个表中的值和正确的返回值

Question

我的任务是创建一个宏，它的行为就像一个VLOOKUP，但规模更大。基本上，我们希望宏查看列顶部的值，然后在不同的表格列中搜索该值。如果它找到该值，它应该将单元格中的值返回到它的右侧。一旦完成，它应该删除该列中的任何重复值和空白单元格。

然后，我需要代码循环到下一列并重复，直到没有更多值要查找。

我可以完美地得到第一列数据，但我似乎无法使它在后续列（循环或直接引用）上工作。任何人都可以将我指向正确的方向吗？ （注意，由于每行的数据量很大，我禁用了最后一行来测试10行的循环）。

Option Explicit 

Sub ReturnActions() 

    Dim itemNumber As String 
    Dim finalRow As Integer 
    Dim i As Integer 
    Dim ws1 As Object 
    Dim ws2 As Object 

    Set ws1 = Worksheets("Intermediate_Data") 
    Set ws2 = Worksheets("Final Workings") 

    ws2.Activate 

    Range("A2").Select 

    itemNumber = ws1.Range("A1").value 
    finalRow = ws2.Range(ActiveCell, ActiveCell.End(xlUp)).Select 

    ws2.Activate 

    'For i = 2 To finalRow 
    For i = 2 To ws2.Range("A10").Row 
     If Cells(i, 1) = itemNumber Then 
      ws2.Cells(i, 2).Copy 
      ws1.Range("A100000").End(xlUp).Offset(1, 0).PasteSpecial 'Transpose:=True 
     End If 

    Next i 

    'Remove duplicates and blanks from data 
    With ws1.Range("A:A") 
     .value = .value 
     .RemoveDuplicates Columns:=1, Header:=xlYes 
     On Error Resume Next 
     .SpecialCells(xlCellTypeBlanks).Delete xlShiftUp 
     On Error GoTo 0 
    End With 

    Range("A2").Offset(0, 1).Select 

    'Select data worksheet 
    ws1.Activate 

    'Select cell A1 
    Range("A1").Select 

    'Select next column item number 
    itemNumber = ActiveCell.Offset(0, 1).Select 

    'Execute code 
    ws2.Activate 

    'For i = 2 To finalRow 
    For i = 2 To ws2.Range("B10").Row 
     If Cells(i, 2) = itemNumber Then 
      ws2.Cells(i, 3).Copy 
      ws1.Range("B100000").End(xlUp).Offset(1, 0).PasteSpecial 'Transpose:=True 
     End If 

    Next i 

    With ws1.Range("B:B") 
     .value = .value 
     .RemoveDuplicates Columns:=1, Header:=xlYes 
     On Error Resume Next 
     .SpecialCells(xlCellTypeBlanks).Delete xlShiftUp 
     On Error GoTo 0 
    End With 

End Sub 

Answer 1

我重构代码”

• 删除不必要的小区选择
• 切换Application.ScreenUpdating以提高速度
• 用于相交修剪列引用，以适应数据
• 修正了几个错误的变量分配

 
    Option Explicit 

    Sub ReturnActions() 
     Application.ScreenUpdating = False 
     Dim itemNumber As String 
     Dim finalRow As Long 
     Dim i As Long 
     Dim ws1 As Worksheet 
     Dim ws2 As Worksheet 

     Set ws1 = Worksheets("Intermediate_Data") 
     Set ws2 = Worksheets("Final Workings") 
     Range("").Value = 2 
     itemNumber = ws1.Range("A1").Value 

     With ws2 

      finalRow = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Row 

      For i = 2 To finalRow 
       If .Cells(i, 1) = itemNumber Then 
        .Cells(i, 2).Copy 
        ws1.Range("A100000").End(xlUp).Offset(1, 0).PasteSpecial 'Transpose:=True 
       End If 

      Next i 

     End With 

     'Remove duplicates and blanks from data 
     With Intersect(ws1.Range("A:A"), ws1.UsedRange) 
      .Value = .Value 
      .RemoveDuplicates Columns:=1, Header:=xlYes 
      On Error Resume Next 
      .SpecialCells(xlCellTypeBlanks).Delete xlShiftUp 
      On Error GoTo 0 
     End With 

     'Select next column item number 
     itemNumber = ws1.Range("B1").Value 

     'For i = 2 To finalRow 
     For i = 2 To ws2.Range("B10").Row 
      If Cells(i, 2) = itemNumber Then 
       ws2.Cells(i, 3).Copy 
       ws1.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial 'Transpose:=True 
      End If 

     Next i 

     With Intersect(ws1.Range("B:B"), ws1.UsedRange) 
      .Value = .Value 
      .RemoveDuplicates Columns:=1, Header:=xlYes 
      On Error Resume Next 
      .SpecialCells(xlCellTypeBlanks).Delete xlShiftUp 
      On Error GoTo 0 
     End With 

     Application.ScreenUpdating = True 
    End Sub 

Answer 2

只是设法弄清楚我出错的地方。我在启动第二个循环时没有定义itemNumber（.Select的变量，而不是.Value）。

Answer 3

我知道你已经接受了一个答案，不过我会发布这个答案，因为可能有一个更简单的方法来实现你的任务，它可能对你将来有用。

从测序的角度来看，是否有理由不在项目开始时一次性删除空白单元格？

从编程的角度来看，我觉得你可能依赖于按键自动化（即超级录音）超过你的需要。如果您将查找数据源读入数组中，那么您可以生成更多的“纯”VBA解决方案，这将极大地简化您的代码。

我不确定我是否确切地理解了你要达到的目标，但下面的代码提供了一个如何解释你的任务的例子。我不认为它会花费太多调整，以满足自己的需要：

Dim dataSheet As Worksheet, finalSheet As Worksheet 
Dim dataColumn As Range, newCell As Range, rng As Range 
Dim columnValues As Variant, searchValue As Variant 
Dim r As Long, c As Long 

Set finalSheet = ThisWorkbook.Worksheets("Final Workings") 
Set dataSheet = ThisWorkbook.Worksheets("Intermediate_Data") 

'Remove all the blanks 
Application.ScreenUpdating = False 
On Error Resume Next 
Set rng = dataSheet.UsedRange.SpecialCells(xlCellTypeBlanks) 
On Error GoTo 0 
If Not rng Is Nothing Then rng.Delete xlShiftUp 

'Read the final workings 
columnValues = finalSheet.UsedRange.Value2 

'Loop through the columns to find values 
c = 1 'this is the column index of your lookup values 
For Each dataColumn In dataSheet.UsedRange.Columns 
    searchValue = dataColumn.Cells(1).Value2 
    For r = 2 To UBound(columnValues, 1) 'start with 2 because 1 is a header 
     If columnValues(r, c) = searchValue Then 
      'Write value into new cell at bottom of column 
      Set newCell = dataColumn.End(xlDown).Offset(1) 
      newCell.Value = columnValues(r, c + 1) 
      'Delete duplicates 
      dataSheet.Range(dataColumn.Cells(2), newCell).RemoveDuplicates Header:=xlNo 
      Exit For 
     End If 
    Next 
    c = c + 1 
Next 
Application.ScreenUpdating = True