【VBA】方眼紙解析 項目範囲特定

'#######################################
'方眼フォーマット　項目範囲取得
'#######################################
Sub GetFieldArea()
    On Error GoTo Catch
    
    Dim i As Integer
    Dim j As Integer
    Dim rng As Range
    Dim strMergeArea As String
    
    Dim CN As ADODB.Connection
    Dim rsArea As ADODB.Recordset     '新規に作成するレコードセット
    
    '新規にレコードセットを作成
    Set rsArea = New ADODB.Recordset
    
    '取得したい項目名を定義
    rsArea.Fields.Append "項目1", adVarChar, 20
    rsArea.Fields.Append "項目2", adVarChar, 20
    rsArea.Fields.Append "項目3", adVarChar, 20

    rsArea.Open
    
    rsArea.AddNew
    
    For i = 0 To rsArea.Fields.Count - 1
        With ThisWorkbook.Worksheets("方眼攻略")
            Set rng = .cells.Find(rsArea.Fields(i).Name, LookAt:=xlWhole)
            strMergeArea = rng.MergeArea.Address
            rng.UnMerge                 '結合セルの解除
            j = 0
            '項目の左端を取得
            While rng.Offset(0, j).Borders(xlEdgeLeft).LineStyle = xlLineStyleNone
                j = j - 1               'セルを左へ移動
            Wend
            Set rng = rng.Offset(0, j)
            j = 0
            '項目の右端を取得
            While rng.Offset(0, j).Borders(xlEdgeRight).LineStyle = xlLineStyleNone
                j = j + 1               'セルを右へ移動
            Wend
            rsArea.Fields(i) = RegExpReplace(Replace(rng.MergeArea.Resize(1, 1 + j).Address, "$", ""), "\d*", "", , True)
            Range(strMergeArea).Merge   '結合セルを戻す
        End With
    Next
    
    
    GoTo Finally
Catch:
    Debug.Print "■エラー【GetFieldArea】" _
                & vbCrLf & Err.Number & vbTab & Err.Description
    MsgBox "エラーが発生しました", , "エラー"
Finally:
    rsArea.Close
    Set rsArea = Nothing
End Sub