在一列中搜索一个字符串，匹配成功时复制下一列的值

Question

我是 VBA 编程新手。我有一个案例，我需要从列的顶部搜索字符串并与该列的后续行中的特定字符串匹配。这是我拥有的：

基本上我需要一个 vba 程序，它将搜索字符串的多次出现并获取第一次出现的匹配字符串旁边的值。如图所示。谁能帮我解决这个问题。我录制了一个宏但没有使用它，因为值每次都在变化。

> Sub Macro1() ' ' Macro1 Macro '
> 
> '
>     Range("B32:B59").Select
>     Selection.Cut
>     ActiveWindow.SmallScroll Down:=-15
>     Range("C2").Select
>     ActiveSheet.Paste
>     ActiveWindow.SmallScroll Down:=39
>     Range("B62:B89").Select
>     Selection.Copy
>     Application.CutCopyMode = False
>     Selection.Cut
>     ActiveWindow.SmallScroll Down:=-60
>     Range("D2").Select
>     ActiveSheet.Paste
>     ActiveWindow.SmallScroll Down:=78
>     Range("B92:B119").Select
>     Selection.Cut
>     ActiveWindow.SmallScroll Down:=-96
>     Range("E2").Select
>     ActiveSheet.Paste
>     ActiveWindow.SmallScroll Down:=114
>     Range("B122:B149").Select
>     Selection.Cut
>     ActiveWindow.SmallScroll Down:=-144
>     Range("F2").Select
>     ActiveSheet.Paste
>     ActiveWindow.SmallScroll Down:=147
>     Range("B152:B179").Select
>     Selection.Cut
>     ActiveWindow.SmallScroll Down:=-168
>     Range("G2").Select
>     ActiveSheet.Paste
>     ActiveWindow.SmallScroll Down:=15
>     Range("A32:A179").Select
>     Selection.ClearContents
>     ActiveWindow.SmallScroll Down:=-42 End Sub

这是我为一个简单的文件录制的MACRO。这是示例结果文件：

Answer 1

这是一个 VBA 解决方案，应该可以帮助您前进。我做了一些假设，因此您可能需要对其进行调整才能满足您的最终要求。

只有运行这个在你的数据副本上。 10,000 行是很多修复工作！

它首先对数据进行排序，遍历值并丢弃重复的行。因此，输出的排序顺序基于 valCol（数据中的列 A）

我在 Sheet3 上使用了我的测试数据，原始数据位于 (stDataRow, valCol)。在代码中更改这些以适合您的数据设置。

最后，请注意，在输出行中，列中值的顺序（从左到右）与它们在原始数据中出现的位置（从下到上）相同。

Option Explicit
Sub CollectData()
Dim ws As Worksheet
Dim stDataRow As Long, endDataRow As Long, valCol As Long
Dim endDataCol As Long, colCnt As Long, c As Long
Dim dataRng As Range, fndVal As Range

Set ws = Sheets("Sheet3")
stDataRow = 2
valCol = 1

    With ws
        endDataRow = Cells(Rows.Count, valCol).End(xlUp).Row
        endDataCol = Cells(stDataRow, Columns.Count).End(xlToLeft).Column
        Set dataRng = .Range(.Cells(stDataRow, valCol), .Cells(endDataRow, endDataCol))

        dataRng.Sort Key1:=Columns(valCol), Order1:=xlAscending

            For c = endDataRow To stDataRow + 1 Step -1
                colCnt = valCol
                Set fndVal = .Cells(c, valCol)
                    Do While fndVal.Value = fndVal.Offset(-1, 0).Value
                        If fndVal.Value = fndVal.Offset(-1, 0).Value Then
                            colCnt = colCnt + 1
                            fndVal.Offset(0, colCnt).Value = fndVal.Offset(-1, 1).Value
                            fndVal.Offset(-1, 0).EntireRow.Delete
                        End If
                    Loop
            Next c
    End With

End Sub

在一列中搜索一个字符串，匹配成功时复制下一列的值

Search for a string in a column and copy the values of the next column when there is succesful match

excel

vba