VBA Search row for instances of pattern in two adjacent cells

[franklin_m]

This one is kicking my bu**.

The data source comes from someone using a worksheet like a piece of paper, and I'm trying to turn it into some useable data. It's a schedule for a year set up like a Gantt chart. Row A, columns 5 through 370 are the day of the year. Column A, rows 1-200 are the individual's name. Columns B, C, & D contain admin data for each name. Columns 5 (E) through 370 contain either an empty cell ( "" ) or an "X" depending on whether that person is scheduled to work that day. There's no regularity in the duration of the work shift (in days).

What I want to do is for each row (name) on the schedule worksheet, loop through the cells looking for the pattern of empty cell followed by "X", then read that day of the year from row "A" and the column where the "X" appears - and write that date to another worksheet (say "Table_Data")where the name of individual is in column "A", the date read from the loop in column "B." Then back on the original data sheet, continue from that date looking now for the pattern of "X" followed by an empty cell ( "" ), where the "X" marks the last day of the shift. Then like above, read that column date and write on that other worksheet in column "C". It would continue looping through the rest of the days in the year and create a new line on the "Table_Data" worksheet for each start end date throughout the year. Once it's searched all 365 days, then move to the next line on the schedule sheet and do the same.

Thanks so much ...
Frank

 

[Snakehips]

@franklin_m Try something like below.'
Assumes the code to be pasted in the code module of the original data sheet and that the 'Table_Data' sheet exists and has headers in row 1.

Sub Get_Schedule()
Dim r, c, n  As Integer
Dim lastrow As Integer
Dim sdate As Long

n = 2  'start row for entry in Table_Data  assumes headers in row 1
lastrow = Range("A" & Rows.Count).End(xlUp).Row  'last row of original data
For r = 2 To lastrow  'assumesheader row A
    For c = 5 To 20
        If LCase(Cells(r, c)) = "x" And LCase(Cells(r, c - 1)) <> "x" Then sdate = Cells(1, c)
        If LCase(Cells(r, c)) = "x" And Cells(r, c + 1) = "" Then
        fdate = Cells(1, c)
        With Sheets("Table_Data")
            .Cells(n, 1) = Cells(r, 1)
            .Cells(n, 2) = sdate
            .Cells(n, 3) = fdate
        End With
    n = n + 1
    End If
    Next c
Next r
End Sub

Hope that helps?

 

[Snakehips]

Run time may benefit by disabling screen updating.

Sub Get_Schedule()
Dim r, c, n  As Integer
Dim lastrow As Integer
Dim sdate As Long

Application.ScreenUpdating = False
n = 2  'start row for entry in Table_Data  assumes headers in row 1
lastrow = Range("A" & Rows.Count).End(xlUp).Row  'last row of original data
For r = 2 To lastrow  'assumesheader row A
    For c = 5 To 20
        If LCase(Cells(r, c)) = "x" And LCase(Cells(r, c - 1)) <> "x" Then sdate = Cells(1, c)
        If LCase(Cells(r, c)) = "x" And Cells(r, c + 1) = "" Then
        fdate = Cells(1, c)
        With Sheets("Table_Data")
            .Cells(n, 1) = Cells(r, 1)
            .Cells(n, 2) = sdate
            .Cells(n, 3) = fdate
        End With
    n = n + 1
    End If
    Next c
Next r
Application.ScreenUpdating = True
End Sub

 

[franklin_m]

Thank you so much ... I'll give it a try later today.