1枚の値で右に戻り値

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

私が間違っていたところでうまくいきました。 2番目のループ（変数.Select、.Valueではなく変数）を開始するときにitemNumberを定義していませんでした。

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