在一個表中的值和正確的返回值

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