Run time error Method Value of Object Range Failed -2147417848 (80010108)

[mahmed1]

Hi All,

I am having a weird problem that each time it prints the data - it gives the error message
Run time error Method Value of Object Range Failed -2147417848 (80010108)

When i debug it and and continue with the code by pressing F8 - It works fine and prints the data however it keeps failing when printing again but again when i step through after debugging - it works fine

Not sure where i am going wrong with this code - please can someone spot where im going wrong

Thank You

' Defined data type to hold data about the Agent
Private Type Agent
    sURN As String
    sTypeName As String
    sDate As Date
    sLeadTrainer As String
    sBaseSite As String
    sSection As String
    sQuestion As String
    sRating As Variant
End Type




Sub transposeme()


Dim RawDatash As Worksheet
Dim Outputsh As Worksheet
Dim RefSh As Worksheet
Dim QuestionSh As Worksheet
Dim ws As Worksheet
Dim QuestionRange As Range
Dim aAgent As Agent


Dim i As Long
Dim Startrow As Long
Dim Lrow As Long
Dim Lcol As Long
Dim Lcol1 As Long
Dim Lcol2 As Long
Dim RawDataCol As Long
Dim OutputLR As Long
Dim MatchHeaders As Variant
Dim cell As Range
Dim found As String


Dim myType As String
Dim BaseSite As String
Set Outputsh = Worksheets("Output")
Set RefSh = Worksheets("Ref")
Set QuestionSh = Worksheets("Q Sheet")


'start row of data output from raw data
Startrow = 3


OutputLR = Outputsh.Range("A" & Rows.Count).End(xlUp).Row
        
For Each rCell In QuestionSh.Range("SheetRange")
    Set ws = ThisWorkbook.Worksheets(rCell.Value)
        
        Lrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
        Lcol1 = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        Lcol2 = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column
        
        If Lcol1 > Lcol2 Then
            Lcol = Lcol1
        Else
            Lcol = Lcol2
        End If
            
        If Lrow = 3 Then
            'NO DATA
        Else
              For Each cell In ws.Range(ws.Cells(1, 1), ws.Cells(1, Lcol))
                    If InStr(1, cell.Value, "(1 = strongly disagree and 5 = strongly agree)", vbTextCompare) > 0 And cell.Offset(1).Value = "" Then
                       found = Trim(Left(cell.Value, InStr(1, cell.Value, "(", vbTextCompare) - 1))
                       cell.Offset(1).Value = found
                    End If
               Next cell
                   'Loop through each agent
               For i = Startrow To Lrow


                       MatchHeaders = Application.WorksheetFunction.Match(RefSh.ListObjects("HeaderTable").ListColumns("Appears in Survey Monkey").DataBodyRange(1), ws.Range(ws.Cells(1, 1), ws.Cells(1, Lcol)), 0)
                       If ws.Cells(i, MatchHeaders).Value <> "" Then
                             
                             'Loop through headers
                             'URN
                               MatchHeaders = Application.WorksheetFunction.Match(RefSh.ListObjects("HeaderTable").ListColumns("Appears in Survey Monkey").DataBodyRange(1), ws.Range(ws.Cells(1, 1), ws.Cells(1, Lcol)), 0)
                               aAgent.sURN = ws.Cells(i, MatchHeaders)
                            
                             'Date
                               MatchHeaders = Application.WorksheetFunction.Match(RefSh.ListObjects("HeaderTable").ListColumns("Appears in Survey Monkey").DataBodyRange(2), ws.Range(ws.Cells(1, 1), ws.Cells(1, Lcol)), 0)
                               aAgent.sDate = DateValue(ws.Cells(i, MatchHeaders))
                            
                             'Type
                               aAgent.sTypeName = ws.Name
                            
                            
                             'Lead Trainer
                               MatchHeaders = Application.WorksheetFunction.Match(RefSh.ListObjects("HeaderTable").ListColumns("Appears in Survey Monkey").DataBodyRange(3), ws.Range(ws.Cells(1, 1), ws.Cells(1, Lcol)), 0)
                               aAgent.sLeadTrainer = ws.Cells(i, MatchHeaders)
                            
                            
                             'Base Site
                               MatchHeaders = Application.WorksheetFunction.Match(RefSh.ListObjects("HeaderTable").ListColumns("Appears in Survey Monkey").DataBodyRange(4), ws.Range(ws.Cells(1, 1), ws.Cells(1, Lcol)), 0)
                  
                                   Select Case ws.Cells(i, MatchHeaders)
                                       Case Is = "Other (please specify)"
                                               BaseSite = "OTHER"
                                       Case Is = "Lon"
                                               BaseSite = "London"
                                       Case Is = "Der"
                                               BaseSite = "Derby"
                                       Case Else
                                               BaseSite = "OTHER"
                                   End Select
                              
                              aAgent.sBaseSite = BaseSite
                               
                                             
                           'Get Question Named Range
                           QuestionNamedRange = Application.WorksheetFunction.VLookup(aAgent.sTypeName, QuestionSh.Range("QuestionLookup"), 2, False)
                           Set QuestionRange = QuestionSh.Range(QuestionNamedRange)
                   
                           For rr = 1 To QuestionRange.Rows.Count
                               For cc = 3 To QuestionRange.Cells(rr, 1).Offset(, -1) + 2
                               
                                   'Section Name
                                    aAgent.sSection = QuestionRange.Cells(rr, 1).Offset(, 1).Value
                                    
                                   'Loop through questions
                                   'Question Name
                                   
                                   aAgent.sQuestion = QuestionRange.Cells(rr, cc).Value
                                   
                                   'Rating
                                   
                                       MatchHeaders = Application.Match(QuestionRange.Cells(rr, cc).Value, ws.Range(ws.Cells(2, 1), ws.Cells(2, Lcol)), 0)
                                       'Outputsh.Cells(OutputLR, 12).Value = ws.Cells(i, MatchHeaders)
                                       
                                       If IsError(MatchHeaders) Then
                                           aAgent.sRating = "N/A"
                                       ElseIf ws.Cells(i, MatchHeaders) = "" Then
                                          aAgent.sRating = "N/A"
                                       Else
                                          aAgent.sRating = ws.Cells(i, MatchHeaders)
                                       End If
                                
                                PrintData aAgent, OutputLR
                                OutputLR = OutputLR + 1
                               Next cc
                           Next rr
                    End If
               Next i
          End If
    Next rCell
End Sub


Private Sub PrintData(pAgent As Agent, pPasteRow As Long)
    With ThisWorkbook.Sheets("Output")
[U][B][COLOR=#ff0000]'ERRORS HERE ALL THE TIME[/COLOR][/B][/U]
        .Cells(pPasteRow, 1).Value = pAgent.sDate
        .Cells(pPasteRow, 2).Value = pAgent.sTypeName
        .Cells(pPasteRow, 3).Value = pAgent.sSection
        .Cells(pPasteRow, 4).Value = pAgent.sURN
        .Cells(pPasteRow, 5).Value = pAgent.sLeadTrainer
        .Cells(pPasteRow, 6).Value = pAgent.sBaseSite
        .Cells(pPasteRow, 7).Value = pAgent.sQuestion
        .Cells(pPasteRow, 8).Value = pAgent.sRating
    End With
End Sub