Copy name of worksheet to an error worksheet

Hello all,
I am new to VBA, and I am having trouble figuring this one out. I'm working with a large set of data that is depth dependent. I only put data in where it changes, so I made two subroutines, one that completes a worksheet where I have entered data, and the other that cycles through the worksheets. There are occasional typos with the way the data is written, so I sometimes have problems with the program.

What I would like to do is write the name of the worksheet with a problem to a list on another worksheet, so that I could run the entire cycle, then have a set of pages to go fix. Is there any way to do this? Thanks!

My code:

Sub FaciesPropogation()
'
'Place cell in second row of depth column and start
'
Dim c As Range, wks As Worksheet, rw As Long, col As Long
Dim i As Integer, j As Integer, Depth, dph As Long


Set wks = Application.ActiveWorkbook.ActiveSheet
Set c = Application.ActiveCell
rw = c.Row
col = c.Column
Depth = c.Value


While Depth <> ""
    Set c = wks.Cells(rw, col)
    
    If c.Value <> (wks.Cells(rw + 1, col).Value - 1) Then
        Set c = wks.Cells(rw + 1, col)
        c.EntireRow.Insert shift:=xlDown
        Set c = wks.Cells(rw + 1, col)
        c.Value = wks.Cells(rw, col).Value + 1
            If c.Value > 10000 Then
                'MsgBox ("Problem")
                'This is where I need help
                GoTo lblerror
            End If
    End If
    For i = 1 To 8
        Set c = wks.Cells(rw, col + i)
        If c.Value = "" Or c.Value = 0 Then
            c.Value = wks.Cells(rw - 1, col + i).Value
        End If
    Next i
    rw = rw + 1
    Depth = wks.Cells(rw + 1, col).Value

Wend
lblerror:
End Sub

Sub WorksheetLoop()

   Dim Current As Worksheet

   For Each Current In Worksheets

      Current.Activate
      Range("a2").Select
      Call FaciesPropogation
      Call Clean_Key
    
   Next

End Sub