CODEWITHSUNDEEP
excelvbastring
LibbyB
LibbyB

Reputation: 81

VBA search string and copy row

I am starting out with a table containing a name which corresponds to a job code and the start date of said job. See below:

![enter image description here

The desired outcome of this is to almost flip it (it is becoming part of a bigger macro, must use VBA for this)

I need dates along the column headings, and the list of unique names. In the column will appear the job for that date. See below for an example:

enter image description here

I have been able to get the code to select all of the rows containing a persons name, however I can't workout how to one by one go through each of the selected rows, copy the job code and paste it to the new table under the correct corresponding date.

Since some jobs have multiple people this code uses InStr() to find occurances of the unqiue names

Sub NewTable()

 Dim Rng As Range
 Dim Cell As Object
 Dim Found As Range
 
 Dim Ws As Worksheet
 Set Ws = Worksheets("Sheet1")
 
 Set Rng = Ws.Range("D:D")
 searchString = "Emily"
 For Each Cell In Rng
 If InStr(Cell, searchString) > 0 Then
      If Not Found Is Nothing Then
          Set Found = Union(myUnion, Cell.EntireRow)
      Else
          Set Found = Cell.EntireRow
      End If
 End If
 Next
 If Found Is Nothing Then
     MsgBox "The text was not found in the selection"
 Else
     Found.Select
 End If

End Sub

Any help would be appreciated

Upvotes: 0

Views: 614

Answers (1)

Tim Williams
Tim Williams

Reputation: 166790

Try this out:

Sub Tester()

    Dim rw As Range, wsData As Worksheet, wsPivot As Worksheet, arr, e, r, c
    
    Set wsData = ThisWorkbook.Worksheets("Input")  'sheet with original data
    Set wsPivot = ThisWorkbook.Worksheets("Pivot") 'sheet for the final table
    
    'loop over each row in the input table
    For Each rw In wsData.Range("B6:E" & wsData.Cells(Rows.Count, "B").End(xlUp).Row).Rows
        If Application.CountA(rw) = 3 Then 'row has data?
        
            'try to match the date: add as new date if no match
            c = Application.Match(CLng(rw.Cells(3).Value), wsPivot.Rows(1), 0)
            If IsError(c) Then
                c = wsPivot.Cells(1, Columns.Count).End(xlToLeft).Column + 1
                If c < 4 Then c = 4 'dates start in D1
                wsPivot.Cells(1, c).Value = rw.Cells(3).Value 'add the date
            End If
            
            arr = Split(rw.Cells(2).Value, ",") 'get array of all names
            'check row for each name: add as new name if no match
            For Each e In arr
                'look for the name in Col B
                r = Application.Match(Trim(e), wsPivot.Columns("B"), 0)
                'if name not found, then add it in the next empty cell
                If IsError(r) Then
                    r = wsPivot.Cells(Rows.Count, "B").End(xlUp).Row + 1
                    If r < 4 Then r = 4 'names begin in B4
                    wsPivot.Cells(r, "B").Value = e
                End If
                wsPivot.Cells(r, c).Value = rw.Cells(1).Value 'add the Job Code
            Next e
        End If
    Next rw
End Sub

Upvotes: 1

Related Questions