特定の背景色のセル抜き出しマクロ

Sub 特定の背景色のセル抜き出しマクロ()


    Dim currentRange As Range
    Dim Rng As Range
    Dim firstAddress As String

    Dim copyBookName As String
    copyBookName = ActiveWorkbook.Name

    Application.FindFormat.Clear
    Application.FindFormat.Interior.Color = vbYellow

    '貼付先のブック作成
    Application.Workbooks.Add
    Dim xWs As Worksheet
    Set xWs = Application.ActiveSheet
    Dim pasteBookName As String
    pasteBookName = ActiveWorkbook.Name

    Workbooks(copyBookName).Activate
    Set currentRange = ActiveSheet.UsedRange.Find(What:="*", SearchFormat:=True)

    If currentRange Is Nothing Then
        MsgBox "修正箇所はありません"
        Exit Sub
    Else

        firstAddress = currentRange.Address


        Set Rng = currentRange
        Do
            Set currentRange = ActiveSheet.UsedRange.Find(What:="*", _
                                           After:=currentRange, _
                                           SearchFormat:=True)

            endrow = getEndRow(pasteBookName)
            endCol = getEndCol(pasteBookName)

            currentRange.Copy Destination:=xWs.Range(xWs.Cells(endrow, endCol))
            'currentRange.Copy Destination:=xWs.Range("A1")

            'ループ終了条件
            If currentRange Is Nothing Then Exit Do
            If currentRange.Address = firstAddress Then Exit Do

            '現在の該当セルを追加選択
            Set Rng = Union(Rng, currentRange)
        Loop
    End If


    Workbooks(pasteBookName).Activate

    'Dim xWs As Worksheet
    'Dim Rng As Range
    'Set Rng = Application.Selection

    'Application.Workbooks.Add
    'Set xWs = Application.ActiveSheet

    'Rng.Copy Destination:=xWs.Range("A1")

End Sub

Function getEndRow(bookName As String) As Integer

     Dim baseBookName As String
     baseBookName = ActiveWorkbook.Name

    Workbooks(bookName).Activate

    With ActiveSheet.UsedRange
        maxRow = .Rows(.Rows.Count).Row
        maxCol = .Columns(.Columns.Count).Column
    End With

    Workbooks(baseBookName).Activate

    getEndRow = maxRow

End Function

Function getEndCol(bookName As String) As Integer

     Dim baseBookName As String
     baseBookName = ActiveWorkbook.Name

    Workbooks(bookName).Activate

    With ActiveSheet.UsedRange
        maxRow = .Rows(.Rows.Count).Row
        maxCol = .Columns(.Columns.Count).Column
    End With

    Workbooks(baseBookName).Activate

    getEndCol = maxCol

End Function