由于某种原因，向下偏移一个单元格不起作用

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