VBA 宏在保持顺序的同时查找特定字符串

Question

我的数据在 A 列和 B 列中有更改请求数据。我需要移动这些数据，以便与单个更改请求相关的所有数据都位于单独的行中。

我一直在研究一个 VBA 宏，它会遍历 Sheet1 A 列以查找特定字符串，然后根据字符串的类型将它们粘贴到 Sheet2 上的不同列。

到目前为止，我已经解决了这个问题，但我的问题如下：我在 A 列中有数据，其中包含更改编号和报告编号。更改编号下可以有多个报告。当我遍历这个时，我设法得到：

• 将数字更改为 A 列
• 将数字报告到 B 列

但是，由于有时在一个更改编号下有多个报告，我很难将这些报告保持在正确的顺序。更改编号需要根据先前更改编号下的报告数量跳过行。如何根据单元格下的报告数量使更改编号跳过单元格？我尝试在当前循环中使用另一个循环来检查更改有多少报告，但似乎无法使其工作。

我现在的代码是这样的：

Sub search_and_extract()

Dim datasheet As Worksheet
Dim reportsheet As Worksheet

Dim SearchString As String
Dim i As Integer

Set datasheet = Sheet1
Set reportsheet = Sheet2

reportsheet.Range("A1:H200").ClearContents

datasheet.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To finalrow
SearchString = datasheet.Range("A" & i)
    If InStr(1, SearchString, "Change Number") Then
        Cells(i, 1).Copy
        reportsheet.Select
        Range("A200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
        datasheet.Select

    ElseIf InStr(1, SearchString, "Report-") Then
        Cells(i, 1).Copy
        reportsheet.Select
        Range("B200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
        datasheet.Select
        End If
Next i
reportsheet.Select
End Sub

pic of the formatting of my excel if that helps

我还将尝试从 Sheet1 列 B 到 Sheet2 列 D、E、F 等获取数据，但这是对未来的担忧。

Answer 1

我认为除了“数据行”（i）之外，您还需要一个“报告行”。

  reportrow = 2
  For i = 1 To finalrow
    SearchString = datasheet.Range("A" & i)
    If InStr(1, SearchString, "Change Number") Then
      Cells(i, 1).Copy
      reportsheet.Select
      Cells(reportrow, 1).PasteSpecial xlPasteFormulasAndNumberFormats
      reportrow = reportrow + 1
      datasheet.Select
    ElseIf InStr(1, SearchString, "Report-") Then
      Cells(i, 1).Copy
      reportsheet.Select
      Cells(reportrow, 2).PasteSpecial xlPasteFormulasAndNumberFormats
      reportrow = reportrow + 1
      datasheet.Select
    End If
  Next i

Answer 2

此代码需要添加对 Microsoft Scripting Runtime 库（用于字典）的引用。我将这段代码建立在几个假设之上：

• 报告始终直接放在相关的更改编号下方。

• 变更编号都是唯一的

• 与更改编号关联的报告编号都是唯一的。

• 报告总是有三种描述：

  • 工作量
  • 要求
  • 发展

• 您没有兴趣直接在每个更改编号下保留“更改主题”注释（这已在下面的编辑中进一步解决）

---

此代码不是直接将信息从一张纸移动到另一张纸，而是将数据收集到字典中；然后将该数据提取回最终工作表。这也将数据从 Sheet1 列 B 获取到 Sheet2 列 D、E、F

---

Sub search_and_extract()

    Dim datasheet As Worksheet
    Dim reportsheet As Worksheet

    Dim SearchString As String
    Dim i As Integer
    Dim j As Integer

    Set datasheet = Sheet1
    Set reportsheet = Sheet2

    Dim chNum As String
    Dim rptNum As String
    Dim ChangeNumbers As New Dictionary

    Dim dictKey1 As Variant
    Dim dictKey2 As Variant

    reportsheet.Range("A1:H200").ClearContents
    finalrow = datasheet.Cells(datasheet.Rows.Count, 1).End(xlUp).Row

    For i = 1 To finalrow
        SearchString = datasheet.Range("A" & i)

        If InStr(1, SearchString, "Change Number") Then
            chNum = datasheet.Cells(i, 1)
            ChangeNumbers.Add chNum, New Dictionary 'For report numbers
        ElseIf InStr(1, SearchString, "Report-") Then
            rptNum = datasheet.Cells(i, 1)
            ChangeNumbers.Item(chNum).Add rptNum, New Dictionary 'For details

            For j = 0 To 2
                ChangeNumbers.Item(chNum).Item(rptNum).Add j, datasheet.Cells(i, 1).Offset(j, 1) ' the details
            Next j
        End If
    Next i

    i = 1
    For Each dictKey1 In ChangeNumbers.Keys
        reportsheet.Cells(i, 1) = dictKey1

        If ChangeNumbers.Item(dictKey1).Count > 0 Then
            For Each dictKey2 In ChangeNumbers.Item(dictKey1).Keys
                reportsheet.Cells(i, 2) = dictKey2

                For j = 0 To 2
                    reportsheet.Cells(i, 4 + j) = ChangeNumbers.Item(dictKey1).Item(dictKey2).Item(j)
                Next j
                i = i + 1 'moves to new row for new report (or next change number
            Next dictKey2
        Else
            i = i + 1 'no reports, so moves down to prevent overwriting change number
        End If
    Next dictKey1
End Sub

---

编辑：

如果需要，包括更改主题的示例。这假设（除上述之外）：

• 变更主题始终在相关报告之前
• 不会有任何报告而不更改主题
• 更改主题将进入 C 列。（例如，可以通过将 reportsheet.Cells(i, 3) 更改为 reportsheet.Cells(i, 7) 将其编辑到 G 列）

细节循环部分也进行了一些更改，以适应不断变化的细节数量。此代码的结构使得每个详细信息类型将始终放在同一列中（即需求列、开发列等）

详细循环部分的主要更改来自以下内容：

For j = 0 To 2
    ChangeNumbers.Item(chNum).Item(chSub).Item(rptNum).Add j, datasheet.Cells(i, 1).Offset(j, 1) ' the details
Next j

对此（仅包括两种示例类型的详细信息。另请注意，目前，目标列号是硬编码的——最好为所需的列号制作常量，以使代码更具可读性——能够且更易于维护。）：

j = 0

Do While IsEmpty(datasheet.Cells(i + j, 1)) Or datasheet.Cells(i + j, 1) = rptNum
    If InStr(1, datasheet.Cells(i + j, 2), "Specified") Then
        ' The 4 after ".Add" is the column number for this detail in sheet2
        ChangeNumbers.Item(chNum).Item(chSub).Item(rptNum).Add 4, datasheet.Cells(i + j, 2) ' the details
    ElseIf InStr(1, datasheet.Cells(i + j, 2), "Total Workload") Then
        ' The 5 after ".Add" is the column number for this detail in sheet2
        ChangeNumbers.Item(chNum).Item(chSub).Item(rptNum).Add 5, datasheet.Cells(i + j, 2) ' the details
    End If

    j = j + 1
Loop

由此而来：

For j = 0 To 2
    reportsheet.Cells(i, 4 + j) = ChangeNumbers.Item(dictKey1).Item(dictKey2).Item(dictKey3).Item(j)
Next j

对此（请注意所需的附加变量）：

Dim dictKey4

For each dictKey4 In ChangeNumbers.Item(dictKey1).Item(dictKey2).Item(dictKey3).Keys
    reportsheet.Cells(i, dictKey4) = ChangeNumbers.Item(dictKey1).Item(dictKey2).Item(dictKey3).Item(dictKey4)
Next dictKey4

---

Sub search_and_extract()

    Dim datasheet As Worksheet
    Dim reportsheet As Worksheet

    Dim SearchString As String
    Dim i As Integer
    Dim j As Integer

    Set datasheet = Sheet1
    Set reportsheet = Sheet2

    Dim chNum As String
    Dim chSub as String
    Dim rptNum As String
    Dim ChangeNumbers As New Dictionary

    Dim dictKey1 As Variant
    Dim dictKey2 As Variant
    Dim dictKey3 As Variant
    Dim dictKey4 As Variant

    reportsheet.Range("A1:H200").ClearContents
    finalrow = datasheet.Cells(datasheet.Rows.Count, 1).End(xlUp).Row

    For i = 1 To finalrow
        SearchString = datasheet.Range("A" & i)

        If InStr(1, SearchString, "Change Number") Then
            chNum = datasheet.Cells(i, 1)
            ChangeNumbers.Add chNum, New Dictionary 'For report numbers
        ElseIf InStr(1, SearchString, "Change Subject") Then
            chSub = datasheet.Cells(i, 1)
            ChangeNumbers.Item(chNum).Add chSub, New Dictionary 'For report numbers
        ElseIf InStr(1, SearchString, "Report-") Then
            rptNum = datasheet.Cells(i, 1)
            ChangeNumbers.Item(chNum).Item(chSub).Add rptNum, New Dictionary 'For details

            j = 0

            'Verifies that the details belong to the current report
            'String checks are included after locating a report to maintain a connection between the report and its details
            Do While IsEmpty(datasheet.Cells(i + j, 1)) Or datasheet.Cells(i + j, 1) = rptNum
                If InStr(1, datasheet.Cells(i + j, 2), "Specified") Then
                    ' The 4 after ".Add" is the column number for this detail in sheet2
                    ChangeNumbers.Item(chNum).Item(chSub).Item(rptNum).Add 4, datasheet.Cells(i + j, 2) ' the details
                ElseIf InStr(1, datasheet.Cells(i + j, 2), "Total Workload") Then
                    ' The 5 after ".Add" is the column number for this detail in sheet2
                    ChangeNumbers.Item(chNum).Item(chSub).Item(rptNum).Add 5, datasheet.Cells(i + j, 2) ' the details
                End If

                j = j + 1
            Loop
        End If
    Next i

    i = 1
    For Each dictKey1 In ChangeNumbers.Keys
        reportsheet.Cells(i, 1) = dictKey1 'Change Number

        If ChangeNumbers.Item(dictKey1).Count > 0 Then
            For Each dictKey2 In ChangeNumbers.Item(dictKey1).Keys
                reportsheet.Cells(i, 3) = dictKey2 'Change Subject; assuming in column C on same row as Change Number

                If ChangeNumbers.Item(dictKey1).Item(dictKey2).Count > 0 Then
                    For Each dictKey3 In ChangeNumbers.Item(dictKey1).Item(dictKey2).Keys 'Report Number
                        reportsheet.Cells(i, 2) = dictKey3
                        'reportsheet.Cells(i, 3) = dictKey2 'Uncomment if you want change subject in every row w/ matching report

                        For each dictKey4 In ChangeNumbers.Item(dictKey1).Item(dictKey2).Item(dictKey3).Keys
                            reportsheet.Cells(i, dictKey4) = ChangeNumbers.Item(dictKey1).Item(dictKey2).Item(dictKey3).Item(dictKey4)
                        Next dictKey4
                        i = i + 1 'moves to new row for new report (or next change number
                    Next dictKey3
                Else
                    i = i + 1 'no reports, so moves down to prevent overwriting change number
                End If
            Next dictKey2
        Else
            i = i + 1 'no change subject, so moves down to prevent overwriting change number
        End If
    Next dictKey1
End Sub