复制一个工作表单元格中特定文本后的数据到另一个工作表第一个工作表出错，其他都很好

Question

此宏在从第一个工作表复制数据时出错。它将记录复制到 D 列中比所需行低的一行，并重复目标工作表中 C 列中的最后一个单元格。发生此错误后，它适用于所有其他剩余的工作表。当我只为一个工作表手动运行它时，使用 F8 键，它运行良好。有人可以帮我解决一下吗？

     Sub My_Approach()

     Dim MAXT As String, fMaxT As String, MsTring As String
     Dim WBk1 As Workbook, WbK2 As Workbook
     Dim wSh4 As Worksheet, sh As Worksheet
     Dim i As Long, lrow1 As Long, LroW2 As Long, lROw3 As Long, LrOw4 As Long
     Dim Mrng1 As Range, searchrange As Range, M As Range, f As Range, FoundRange1 As Range, 
     fOUNDranGE2 As Range, searcHRange1 As Range, fOUNDranGE3 As Range, mYtOTAL As Range
     Dim colFind As Collection, t As ListObjects
     MAXT = "FROM:"
     fMaxT = "TO:"
     MsTring = "MyNUMBER"
     Set WBk1 = ActiveWorkbook

     With WBk1
        If ActiveWindow.SelectedSheets.Count > 1 Then
           For Each sh In WBk1.Worksheets
              sh.Select False
           Next
        End If
      End With

      Set WbK2 = Workbooks("TempBook.xlsx")
      Set wSh4 = WbK2.Sheets("RetrivedData")
       wSh4.Tab.Color = vbBlue
    

                  For Each sh In WBk1.Sheets
                    If sh.Name Like "20*" Then

                        sh.Select
                    With sh
                     .Cells.UnMerge
                     .rows("1:13").Interior.Color = vbRed
                     .rows("1:13").Delete
                    
                   End With

                    With sh
                       lrow1 = sh.Range("A" & .rows.Count).End(xlUp).row
                    End With

                   Set searchrange = sh.Range("A1:A" & lrow1)

                   Set FoundRange1 = searchrange.Find(MAXT, , xlValues, xlWhole, xlByRows, False)
                    LroW2 = FoundRange1.row


                    Set fOUNDranGE2 = searchrange.Find(fMaxT, , xlValues, xlWhole, xlByRows, False)
                       lROw3 = fOUNDranGE2.row

                  Set Mrng1 = sh.Range("A1:L" & lROw3)

                  With wSh4
                   LrOw4 = wSh4.Range("C" & .rows.Count).End(xlUp).row
                      Mrng1.Copy
                    wSh4.Range("C" & LrOw4).Offset(1, 0).PasteSpecial xlPasteValues
                    wSh4.Range("C" & LrOw4).Offset(1, -2).Formula = WBk1.Name
                    wSh4.Range("C" & LrOw4).Offset(1, -1).Formula = sh.Name
                     Application.CutCopyMode = False
                   
                     LrOw4 = wSh4.Range("C" & .rows.Count).End(xlUp).row

                  Set searcHRange1 = wSh4.Range("C" & LrOw4)
                  Set fOUNDranGE3 = searcHRange1.Find(fMaxT, , xlValues, xlWhole, xlByRows, False)

                  If fOUNDranGE3.Value = "TO:" Then
                  Set mYtOTAL = fOUNDranGE3.Offset(0, 4)
                  mYtOTAL.Interior.Color = vbGreen
                  End If
                 End With

                 Set M = sh.Range(sh.Cells(fOUNDranGE2.Offset(0, 0).row, fOUNDranGE2.Offset(0, 0).Column), sh.Cells(lrow1, 1))
                 Set colFind = FindAll(M, MsTring)

                 For Each f In colFind
                         If f.Value = "MyNUMBER" Then

                      With wSh4
                          LrOw4 = wSh4.Range("C" & .rows.Count).End(xlUp).row

                         wSh4.Range("C" & LrOw4).Offset(1, 0).Value = f.Offset(2, 0).Value
                           wSh4.Range("C" & LrOw4).Offset(1, 1).Value = f.Offset(4, 2).Value
                          wSh4.Range("C" & LrOw4).Offset(1, 2).Value = f.Offset(2, 7).Value
                         wSh4.Range("C" & LrOw4).Offset(1, 3).Value = f.Offset(2, 8).Value

                 If f.Offset(2, 8).Value = "SQ FT" Then
                         wSh4.Range("C" & LrOw4).Offset(1, 4).Value = f.Offset(2, 7).Value / 43560
                 Else
                         wSh4.Range("C" & LrOw4).Offset(1, 4).Value = f.Offset(2, 7).Value
                End If
                    wSh4.Range("C" & LrOw4).Offset(1, 5).Value = f.Offset(6, 10).Value
               End With
                End If
                Next f

             End If

             With wSh4
                      LrOw4 = wSh4.Range("C" & .rows.Count).End(xlUp).row
             End With

             wSh4.Range("C1:C" & LrOw4).TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
    :=Array(1, 2), TrailingMinusNumbers:=True
    
              mYtOTAL.Offset(0, -1).Formula = WorksheetFunction.CountA(wSh4.Range(wSh4.Cells(mYtOTAL.Offset(1, -4).row, mYtOTAL.Offset(1, -4).Column), wSh4.Cells(LrOw4, 3)))
              mYtOTAL.Offset(0, 1).Formula = WorksheetFunction.Sum(wSh4.Range(wSh4.Cells(mYtOTAL.Offset(1, 1).row, mYtOTAL.Offset(1, 1).Column), wSh4.Cells(LrOw4, 7)))
              mYtOTAL.Formula = WorksheetFunction.Sum(wSh4.Range(wSh4.Cells(mYtOTAL.Offset(1, 0).row, 
              mYtOTAL.Offset(1, 0).Column), wSh4.Cells(LrOw4, 6)))
              mYtOTAL.Offset(0, 1).Formula = WorksheetFunction.Sum(wSh4.Range(wSh4.Cells(mYtOTAL.Offset(1, 1).row, mYtOTAL.Offset(1, 1).Column), wSh4.Cells(LrOw4, 7)))


                Next sh

              WbK2.Save

                End Sub