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.

Yea but I figured that it is not super relevant since those are not problematic in the same sense. — user2859557, May 23 '18 at 16:23

score 1 · Answer 1 · answered May 23 '18 at 15:44

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

This works exactly as I tried to make mine work. Thank you. Now I need to think about the logic to understand it better. — user2859557, May 24 '18 at 05:28

Mistella · Answer 2 · 2018-05-29T13:51:19.040

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

Hmm, this works better than the copy-paste method since this runs much faster and with less performance requirements. Thank you for this. I need to try to understand the code now :) — user2859557, May 24 '18 at 05:48
It interestingly extracts the Change Subject notes only if there are multiple Reports under the change. Gonna come back when I figure it out. — user2859557, May 24 '18 at 06:00
@user2859557 The following link leads to an answer with some basic dictionary properties/methods, with some examples. https://stackoverflow.com/a/32487945/9259306 — Mistella, May 24 '18 at 13:22
@user2859557 I tried double-checking the second code I included, running it on sample data (without changing anything). I attached images of my sample data, before/after. It looked like it worked for me. Did you make any changes to the code? — Mistella, May 24 '18 at 13:57
Sorry for late reply. I only modified the strings that are sought after with InStr since I didn't include the complete original data for privacy reasons. But now that I think it might be this reason for why the code isn't working since there arent always 3 details under a change. I have been trying to make it work through InStr searches for the change details too but there I seem to lose the ordering. — user2859557, May 29 '18 at 07:10
@user2859557 I've updated the "Edit" section to account for the variable number of "details". I also included some explanation of the sections I changed. — Mistella, May 29 '18 at 13:53
I am speechless for your helpfulness. I actually tried to do the exactly same thing (matching strings) with some success but it was awful looking and had bugs. Would've never figured out how useful dictionaries are for a task like this. — user2859557, May 30 '18 at 05:24

VBA macro to find specific strings while maintaining the ordering

2 Answers2