VBA代码异常排查：多工作表TH匹配后复制B2数据至新表问题

需求说明 #

• 工作簿内所有工作表仅A、B列包含数据
• 遍历所有工作表的A列，搜索字符串TH
• 若某工作表的A列中存在TH，则复制该工作表B2单元格的数据
• 新建名为TH的工作表，将所有符合条件的B2数据依次粘贴到该表的连续单元格（从A1开始）

现有代码（拼凑所得） #

Sub CopyData()

    Dim I As Integer
    Dim Cell As Range
    Dim RowCNT As Integer
    Dim Exists As Boolean

    RowCNT = 1

    For I = 1 To ActiveWorkbook.Worksheets.Count
        For Each Cell In Worksheets(I).Range("A1:A" & Worksheets(I).Cells(Worksheets(I).Rows.Count, "A").End(xlUp).Row)
            pos = InStr(Cell.Value, "TH")
            If pos > 0 Then
                For n = 1 To ActiveWorkbook.Worksheets.Count
                   If Worksheets(n).Name = "TH" Then
                      Exists = True
                   End If
                Next n
                If Not Exists Then
                   Worksheets.Add.Name = "TH"
                End If
                   Sheets("TH").Cells(RowCNT, 1).Value = Worksheets(I).Range("B2").Value
                   RowCNT = RowCNT + 1
            End If
        Next Cell
    Next I

End Sub

运行异常情况 #

• 当TH工作表未创建且第一个工作表为活动表时：创建TH表后数据从A2开始粘贴，且缺失最后一条数据；再次运行代码时数据从A1开始粘贴且包含最后一条。
• 当TH工作表未创建且活动表为非第一个工作表时：创建TH表后数据从A1开始粘贴，但缺失最后一条数据；再次运行代码时数据从A1开始粘贴且包含最后一条。
• 当TH工作表已存在时：单次运行代码即可正常从A1开始粘贴且包含所有数据。

求助需求 #

1. 指出代码中的逻辑问题、冗余写法
2. 在现有代码基础上修改，实现需求，方便理解学习

内容的提问来源于stack exchange，提问作者Mostafa