Offset one cell down doesn't work for some reason - excel

Question

I would like to have up to 6 records which will be based on the answers located in the row beneath.
My code so far looks like this:
Sub Copy_Data_Correctly(ByRef datSource As Worksheet, datTarget As Worksheet)
'QUESTION 1
Const TM_PM As String = "*PM is required*"
Dim que1 As Range
Dim ans1 As Range
Set que1 = Sheets("Sheet1").Range("A1:A100").Find(What:=TM_PM, _
Lookat:=xlPart, LookIn:=xlValues)
If Not que1 Is Nothing Then
'MsgBox ("The question about PM or TM wasn't found")
End If
Set ans1 = que1.Offset(1)
'QUESTION 2
Const LID_LIFTED As String = "*be lifted*"
Dim que2 As Range
Dim ans2 As Range
Set que2 = Sheets("Sheet1").Range("A1:A100").Find(What:=LID_LIFTED, _
Lookat:=xlPart, LookIn:=xlValues)
If Not que2 Is Nothing Then
End If
Set ans2 = que2.Offset(1)
'EXTRACTING THE DATA
Dim lrow1 As Long, lrow2 As Long, lrow3 As Long, lrow4 As Long, lrow5 As Long, lrow6 As Long
lrow1 = datTarget.Range("E" & datTarget.Rows.Count).End(xlUp).Row + 1
lrow2 = datTarget.Range("F" & datTarget.Rows.Count).End(xlUp).Row + 1
que1.Copy
datTarget.Range("E1").PasteSpecial xlPasteValuesAndNumberFormats
ans1.Copy
datTarget.Range("E" & lrow1).PasteSpecial xlPasteValuesAndNumberFormats
que2.Copy
datTarget.Range("F1").PasteSpecial xlPasteValuesAndNumberFormats
ans2.Copy
datTarget.Range("F" & lrow2).PasteSpecial xlPasteValuesAndNumberFormats
End Sub
If I have the second question & answer standalone, then it works. Unfortunately after adding the Q&A1 the error:
Object variable or with variable not set
occurs at the line:
Set ans1 = que1.Offset(1)
why the code behaves like that?

Answer 1

Copy Conditionally
Using the Find method, it will attempt to find each string, containing wild characters, from a list in range A1:A100 of one worksheet (source), then take this matching value (which is different (no wild characters)), and by using Application.Match, it will attempt to find a match in the headers of another worksheet (destination). If a match is found, then the result, the value of the cell below the previously found cell, will be written into the first available row. If no match is found, a new header will be created from the value of the found cell, and the value below the found cell will be written into the first available row.
Option Explicit
Sub CopyData( _
ByVal wsSource As Worksheet, _
ByVal wsDestination As Worksheet)
' Add more: comma separated, no spaces
Const sCriteriaList As String = "*PM is required,*be lifted*"
Const sCriteriaListDelimiter As String = ","
Const sAddress As String = "A1:A100"
Const dfhCellAddress As String = "E1"
Dim sCriteria() As String
sCriteria = Split(sCriteriaList, sCriteriaListDelimiter)
Dim srg As Range: Set srg = wsSource.Range(sAddress)
Dim dfhCell As Range: Set dfhCell = wsDestination.Range(dfhCellAddress)
Dim dfRow As Long: dfRow = dfhCell.Row
Dim dfCol As Long: dfCol = dfhCell.Column
Dim dlhCell As Range: Set dlhCell = _
wsDestination.Cells(dfRow, wsDestination.Columns.Count).End(xlToLeft)
Dim dhrg As Range
If dlhCell.Column < dfCol Then
Set dhrg = dfhCell
Else
Set dhrg = wsDestination.Range(dfhCell, dlhCell)
End If
Dim dlCol As Long: dlCol = dhrg.Columns(dhrg.Columns.Count).Column
Dim dlCell As Range
Set dlCell = _
wsDestination.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious)
Dim dRow As Long
If Not dlCell Is Nothing Then
If dlCell.Row <= dfhCell.Row Then
dRow = dfhCell.Row + 1
Else
dRow = dlCell.Row + 1
End If
Else
dRow = dfhCell.Row + 1
End If
Dim sCell As Range
Dim sQuestion As String
Dim sAnswer As String
Dim drrg As Range
Dim dhIndex As Variant
Dim n As Long
For n = 0 To UBound(sCriteria)
Set sCell = srg.Find( _
sCriteria(n), srg.Cells(srg.Cells.Count), xlValues, xlWhole)
If Not sCell Is Nothing Then
sQuestion = sCell.Value
sAnswer = CStr(sCell.Offset(1).Value)
dhIndex = Application.Match(sQuestion, dhrg, 0)
If IsNumeric(dhIndex) Then
wsDestination.Cells(dRow, dhIndex + dfCol - 1).Value = sAnswer
Else
Set dhrg = dhrg.Resize(, dhrg.Columns.Count + 1)
dlCol = dlCol + 1
wsDestination.Cells(dfRow, dlCol).Value = sQuestion
wsDestination.Cells(dRow, dlCol).Value = sAnswer
End If
End If
Next n
End Sub