結合セルの番号を取得するマクロ

エクセルの表より結合されたセルに入力された値を取得するマクロ。
ただし、グレーアウトされた行の番号は取得しない。
※下記の画像の場合であれば、No.2,4,6,13～16 を取得。

【画像】

尚、当マクロを使用するためには、以下の設定が必要。

【参照設定ダイアログを表示】

ツール　＞　参照設定　＞　「Microsoft Scripting Runtime」をクリック

以下、マクロ。

Sub エビデンス取得No一覧()
    
    Dim MaxRow As Long
    Dim MaxCol As Long
    
    '表の最終行と最終列を取得
    With ActiveSheet.UsedRange
        MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
        MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
    End With
    
    '表の最初行
    Dim starRow As Long
    starRow = 6
    
    '番号列
    Dim nmColum As Long
    nmColum = 2
    
    '結果列
    Dim resultColum As Long
    resultColum = 17
    
    '結果列の色と番号列の値
    Dim cellColor As String
    Dim val As String
    
    Dim numList As Collection
    Set numList = New Collection
    
    Dim outMsg As String
        
    Dim fso As FileSystemObject
    Set fso = New FileSystemObject ' インスタンス化
        
    Dim dirNm As String
    dirNm = "C:\VBA_TMP"
    Dim fileNm As String
    fileNm = "tmpNum.txt"
    
    Dim fullPath As String
    fullPath = fso.BuildPath(dirNm, fileNm)
    
    If (fso.FileExists(fullPath)) Then
        '何もしない
    Else
        fso.CreateFolder (dirNm)
    End If
    
    '出力ファイルを作成 or 開く
    Dim ts As TextStream
    Set ts = fso.OpenTextFile(fullPath, ForWriting, True, TristateFalse) ' ファイルを Shift-JIS で開く
                
        
    For i = starRow To MaxRow
        cellColor = Cells(i, resultColum).Interior.color
        val = Cells(i, nmColum).Value
       
       
        If val <> "" And cellColor = "16777215" Then
            ts.WriteLine (val)
        End If
    Next i
    
    ts.Close ' ファイルを閉じる
    
    ' 後始末
    Set ts = Nothing
    Set fso = Nothing
    
    
    'クリップボードにエビデンス取得番号を格納
    SetCB fullPath

    MsgBox "エビデンス取得番号一覧ファイルを作成しました。" & Chr(13) & "保存先：" & fullPath & Chr(13) & Chr(13) & "※上記保存先のファイルパスはクリップボードにコピーされました。"
    
   
End Sub

Private Sub SetCB(ByVal str As String)
'クリップボードに文字列を格納
  With CreateObject("Forms.TextBox.1")
    .MultiLine = True
    .Text = str
    .SelStart = 0
    .SelLength = .TextLength
    .Copy
  End With
End Sub