在一个工作表中返回值，并将值返回到右侧

我的任务是创build一个像VLOOKUP一样的macros，但规模更大。 基本上，我们希望macros查看列顶部的值，然后在不同的表格列中search该值。 如果find该值，则应将单元格中的值返回到其右侧。 完成后，应删除该列中的任何重复值和空白单元格。

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

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

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

我重构了你的代码

• 删除了不必要的单元格select
• 切换Application.ScreenUpdating以提高速度
• 使用交集修剪列引用以适应数据
• 修复了一些不好的variables赋值

    选项显式

     Sub ReturnActions（）
         Application.ScreenUpdating = False
         Dim itemNumber As String
         Dim finalRow As Long
        昏暗我只要
        昏暗的ws1作为工作表
        昏暗的ws2作为工作表

        设置ws1 =工作表（“Intermediate_Data”）
        设置ws2 =工作表（“最终工作”）
        范围（“”）。值= 2
         itemNumber = ws1.Range（“A1”）。Value

        用ws2

             finalRow = .Range（“A2”，.Range（“A”＆Rows.Count）.End（xlUp））。Row

            对于我= 2到finalRow
                如果.Cells（i，1）= itemNumber那么
                     .Cells（i，2）.Copy
                     ws1.Range（“A100000”）。End（xlUp）.Offset（1，0）.PasteSpecial'Transpose：= True
                万一

            接下来我

        结束

         '从数据中删除重复和空白
        与相交（ws1.Range（“A：A”），ws1.UsedRange）
             .Value = .Value
             .RemoveDuplicates Columns：= 1，Header：= xlYes
            在错误恢复下一步
             .SpecialCells（xlCellTypeBlanks）。删除xlShiftUp
            在错误转到0
        结束

         'select下一列项目编号
         itemNumber = ws1.Range（“B1”）。Value

         “对于我= 2到最后行程
        对于i = 2到ws2.Range（“B10”）
            如果Cells（i，2）= itemNumber Then
                 ws2.Cells（i，3）.Copy
                 ws1.Range（“B”＆Rows.Count）.End（xlUp）.Offset（1，0）.PasteSpecial'Transpose：= True
            万一

        接下来我

        使用相交（ws1.Range（“B：B”），ws1.UsedRange）
             .Value = .Value
             .RemoveDuplicates Columns：= 1，Header：= xlYes
            在错误恢复下一步
             .SpecialCells（xlCellTypeBlanks）。删除xlShiftUp
            在错误转到0
        结束

         Application.ScreenUpdating = True
    结束小组

Answer 2

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

Answer 3

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

从序列的angular度来看，在项目开始的时候你是不是一下子就把空白的单元格全部删除的，是有原因的？

从编程的angular度来看，我觉得你可能会比你所需要的更多地依靠按键的自动操作（即超级录音）。 如果您将查找数据源读取到数组中，那么您可以生成更多的“纯”VBA解决scheme，这将极大地简化您的代码。

我不确定我是否正确地理解了你要实现的目标，但下面的代码提供了一个我如何解释你的任务的例子。 我认为不需要太多的调整来适应自己的需求：

 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