In this Macro not give accurate result

[Shankar618]

Hi

I have data in Data Tab From In E1:AK1 Dates this macro Each code give start Date & End in Reoprt Tab but this macro give result only Starting Result & Ending Result please tell me how to change in code give All code Result

In same Data Additional macro i want that macro Search Where is 1st code mention that column which date mention that date i want Start Date & then search Where is R mention before 1 day that is End Date i want. Please tell me how to do this

 

[Shankar618]

I have resolve 1st problem macro give result each code start date & end date
I need help where is R mention before 1 day give end date If any Other code Or any blank cell does not matter.
If 1st code found R in Row Range then give end date in Report sheet

Please tell me how to do this

 

[Luke M]

HI shankar,

I'm having trouble understanding your request. Can you provide an example of what the final report should look like?

 

[Shankar618]

here is mention how expected result look like

 

[Luke M]

Try this

Sub TransferResults()
Dim lastRow As Long
Dim recRow As Long
Dim lastCol As Long
Dim colCounter As Long
Dim rowCounter As Long
Dim wsDest As Worksheet
Dim wsSource As Worksheet
Dim recOn As Boolean
Dim cVal As String


Set wsDest = Worksheets("Report")
Set wsSource = Worksheets("Data")

Application.ScreenUpdating = False
With wsDest
    .Range("2:" & .Rows.Count).EntireRow.ClearContents
End With

recRow = 2
recOn = False

With wsSource
    lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
    For rowCounter = 2 To lastRow
        For colCounter = 5 To lastCol - 1
            cVal = .Cells(rowCounter, colCounter).Value
            If cVal <> "" Then
                If recOn Then
                    If UCase(cVal) = "R" Then
                        'Finish an record that's been started
                        wsDest.Cells(recRow, 4).Value = .Cells(1, colCounter - 1).Value
                        recRow = recRow + 1
                        recOn = False
                    End If
                Else 'Haven't started logging anything...
                    If UCase(cVal) = "R" Then
                        'If first thing is R, immediately end
                        wsDest.Cells(recRow, 1).Value = .Cells(rowCounter, "B").Value
                        wsDest.Cells(recRow, 2).Value = cVal
                        wsDest.Cells(recRow, 4).Value = .Cells(1, colCounter - 1).Value
                        wsDest.Cells(recRow, 5).Value = .Cells(rowCounter, lastCol).Value
                        recRow = recRow + 1
                    Else
                        'Otherwise, start a new record
                        recOn = True
                        wsDest.Cells(recRow, 1).Value = .Cells(rowCounter, "B").Value
                        wsDest.Cells(recRow, 2).Value = cVal
                        wsDest.Cells(recRow, 3).Value = .Cells(1, colCounter).Value
                        wsDest.Cells(recRow, 5).Value = .Cells(rowCounter, lastCol).Value
                        'lastGoodCol = colCounter
                    End If
                End If
            End If
        Next colCounter
    Next rowCounter
End With
Application.ScreenUpdating = True
                   
End Sub

 

[Shankar618]

Hi Luke M

This Macro Fantastic work thanks for this i appreciate your efforts.
Only one thing in attach file if u look I6 R is mention then in that row Next R is not mention but macro give end date as(05-07-2015) i think next row J7 R is mention but that is different Number i do not want next row data if R mention first. In this type 8-7-2015 is start date no end date & Next Row 12348 End date as 5-7-2015. please tell me how to corrected in coding part. I am also highlighted in attach file in yellow color

 

[Luke M]

Ah, I see. Ammended the code to check if a record has been left open before moving to next row.

Sub TransferResults()
Dim lastRow As Long
Dim recRow As Long
Dim lastCol As Long
Dim colCounter As Long
Dim rowCounter As Long
Dim wsDest As Worksheet
Dim wsSource As Worksheet
Dim recOn As Boolean
Dim cVal As String


Set wsDest = Worksheets("Report")
Set wsSource = Worksheets("Data")

Application.ScreenUpdating = False
With wsDest
    .Range("2:" & .Rows.Count).EntireRow.ClearContents
End With

recRow = 2
recOn = False

With wsSource
    lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
    For rowCounter = 2 To lastRow
        For colCounter = 5 To lastCol - 1
            cVal = .Cells(rowCounter, colCounter).Value
            If cVal <> "" Then
                If recOn Then
                    If UCase(cVal) = "R" Then
                        'Finish an record that's been started
                       wsDest.Cells(recRow, 4).Value = .Cells(1, colCounter).Value - 1
                        recRow = recRow + 1
                        recOn = False
                    End If
                Else 'Haven't started logging anything...
                   If UCase(cVal) = "R" Then
                        'If first thing is R, immediately end
                       wsDest.Cells(recRow, 1).Value = .Cells(rowCounter, "B").Value
                        wsDest.Cells(recRow, 2).Value = cVal
                        wsDest.Cells(recRow, 4).Value = .Cells(1, colCounter).Value - 1
                        wsDest.Cells(recRow, 5).Value = .Cells(rowCounter, lastCol).Value
                        recRow = recRow + 1
                    Else
                        'Otherwise, start a new record
                       recOn = True
                        wsDest.Cells(recRow, 1).Value = .Cells(rowCounter, "B").Value
                        wsDest.Cells(recRow, 2).Value = cVal
                        wsDest.Cells(recRow, 3).Value = .Cells(1, colCounter).Value
                        wsDest.Cells(recRow, 5).Value = .Cells(rowCounter, lastCol).Value
                        'lastGoodCol = colCounter
                   End If
                End If
            End If
        Next colCounter
       
        'If we left a record open, at this point, it stays open
        'and we move to next record
        If recOn Then
            recRow = recRow + 1
            recOn = FalseFalse
        End If

    Next rowCounter
End With
Application.ScreenUpdating = True
MsgBox ("DONE Data is Ready")
                   
End Sub

 

[Shankar618]

Luke M Sir

Thanks For Support me Its work 100% fine now your solution method is very good i am not think in this way thats why i am stuck with current file macro but ur solution after that i got how to analysis problem.