VBA macro to find specific strings while maintaining the ordering

Question

My data has change request data in column A and B. I would need to move this data so that all data related to a single change request would be on its own row.

I have been working on an VBA macro that would loop through Sheet1 A-column to find specific strings and then paste those to different columns on Sheet2 depending on which type of String it is.

So far I have gotten somewhere with this but my problem is as follows: I have data in A-column that has Change Numbers and Report Numbers. Change number can have multiple Reports under it. When I loop through this I manage to get:

• Change Numbers to column A
• Report Numbers to column B

However, as there are sometimes multiple reports under a single Change Number I am struggling to keep these in the right order. Change numbers would need to skip rows according to the amount of reports under the previous change number. How do I make the change numbers skip cells according to the amount of reports under them? I tried using another loop inside my current loop to check how many reports does a change have but couldn't seem to make it work.

My code at the moment looks like this:

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

I will be also trying to get the data from Sheet1 column B to Sheet2 columns D,E,F etc but that is a worry of the future.

Answer 1

This code requires adding a reference to the Microsoft Scripting Runtime library (for the dictionaries). I based this code on several assumptions:

• That the reports are always placed directly under their associated change number.

• That the Change Numbers are all unique

• That the Report Numbers associated with a change number, are all unique.

• That there are always three descriptions to a report:

  • Workload
  • Requirements
  • Development

• That you have no interest in preserving the "Change Subject" Notes directly under each Change Number (This has been further addressed in edit below)

---

Instead of directly moving the information from one sheet to the other, this code collects the data into a dictionary; then extracts that data back to the final worksheet. This also gets the data from Sheet1 column B to Sheet2 columns 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

---

Edit:

Sample on including change subject, if desired. This assumes (in addition to above):

• The change subject is always before the relevant report(s)
• That there will not be any reports without change subjects
• That the change subject will go in column C. (This can be edited, for example, to column G by changing reportsheet.Cells(i, 3) to reportsheet.Cells(i, 7))

There were also some changes to the detail-loop sections to accommodate for a changing number of details. This code is structured so that each detail-type will consistently be placed in the same column (i.e. a column for the Requirements, a column for the Development, etc.)

Primary changes for the detail-loop sections were from this:

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

to this (Only two sample types of detail were included. Also note that currently, the destination column number is hard-coded -- it may be better to make constants for the required column numbers, to make the code more read-able and easier to maintain.):

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

and from this:

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

to this (Please note the additional variable required):

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

Answer 2

I think you want a "reportrow" in addition to a "datarow" (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