Copy visible cells to visible cells

' Copy visible cells from one range to visible cells in another range.
Function VisibleToVisible() As Boolean
    Const cstrTitle As String = "Visible To Visible"
    Const clngFirst As Long = 1
    Const clngRange As Long = 8
    Const clngRow As Long = 1
    Const clngCol As Long = 2
    '
    Dim strErrMsg As String
    '
    Dim bolAlerts As Boolean
    Dim bolEvents As Boolean
    Dim bolStatus As Boolean
    Dim bolScreen As Boolean
    Dim xlcCalc As XlCalculation
    '
    Dim rngSrcCell As Range
    Dim rngSrc As Range
    Dim rngDst As Range
    Dim lngSrcRow As Long
    Dim lngSrcCol As Long
    Dim lngDstRow As Long
    Dim lngDstCol As Long
    '
    Dim lngNumSrcCells As Long
    Dim varAddresses() As Variant
    Dim lngNdx As Long
    '
    VisibleToVisible = False
    strErrMsg = vbNullString
    On Error GoTo Err_Exit
    '
    ' Get the ranges to be used.
    Set rngSrc = Application.InputBox("Select source range:", cstrTitle, Selection.Address, Type:=clngRange)
    Set rngSrc = rngSrc.SpecialCells(xlCellTypeVisible)
    Set rngDst = Application.InputBox("Select destination:", cstrTitle, Type:=clngRange)
    Set rngDst = rngDst.Areas(clngFirst).Cells(clngFirst)
    '
    With Application
        ' Save current values of settings.
        bolAlerts = .DisplayAlerts
        bolEvents = .EnableEvents
        xlcCalc = .Calculation
        bolScreen = .ScreenUpdating
        '
        ' Turn off the settings.
        .Calculation = xlCalculationManual
        .StatusBar = False
        .DisplayAlerts = False
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    '
    lngSrcRow = rngSrc.Cells(clngFirst).Row
    lngSrcCol = rngSrc.Cells(clngFirst).Column
    '
    ' Build an array of rows and columns for each source cell, and sort them.
    lngNumSrcCells = rngSrc.Cells.Count
    ReDim varAddresses(1 To lngNumSrcCells, clngRow To clngCol)
    lngNdx = 0
    For Each rngSrcCell In rngSrc.Cells
        lngNdx = lngNdx + 1
        varAddresses(lngNdx, clngRow) = rngSrcCell.Row
        varAddresses(lngNdx, clngCol) = rngSrcCell.Column
    Next
    BubbleSort2D varAddresses, True, True
    '
    ' Move through the source address array, copying those cells to their destination.
    With rngSrc.Parent
        lngSrcRow = varAddresses(clngFirst, clngRow) - 1
        lngDstRow = rngDst.Cells(clngFirst).Row - 1
        For lngNdx = 1 To lngNumSrcCells
            ' Are we on a new source row?
            If (varAddresses(lngNdx, clngRow) > lngSrcRow) Then
                ' Yes, so advance the destination row as well.
                lngSrcRow = varAddresses(lngNdx, clngRow)
                Do
                    lngDstRow = lngDstRow + 1
                Loop Until (Not rngDst.Parent.Rows(lngDstRow).EntireRow.Hidden)
                lngDstCol = rngDst.Cells(clngFirst).Column - 1
            End If
            ' Increment the column until past any hidden columns.
            lngDstCol = lngDstCol + 1
            Do While rngDst.Parent.Columns(lngDstCol).EntireColumn.Hidden
                lngDstCol = lngDstCol + 1
            Loop
            ' If the source and destination don't overlap, perform the copy.
            If (Application.Intersect(rngSrc, rngDst.Parent.Cells(lngDstRow, lngDstCol)) Is Nothing) Then
                With .Cells(varAddresses(lngNdx, clngRow), varAddresses(lngNdx, clngCol))
                    rngDst.Parent.Cells(lngDstRow, lngDstCol).HorizontalAlignment = .HorizontalAlignment
                    rngDst.Parent.Cells(lngDstRow, lngDstCol).NumberFormat = .NumberFormat
                    rngDst.Parent.Cells(lngDstRow, lngDstCol).Value = .Value
                End With
            End If
        Next
    End With
    '
    VisibleToVisible = True
Housekeeping:
    ' Restore the settings.
    With Application
        .ScreenUpdating = bolScreen
        .EnableEvents = bolEvents
        .DisplayAlerts = bolAlerts
        .StatusBar = vbNullString
        .Calculation = xlcCalc
    End With
    ' Display any error message.
    If (Trim(strErrMsg) <> vbNullString) Then
        MsgBox strErrMsg, vbCritical + vbOKOnly, cstrTitle
    End If
    Exit Function
Err_Exit:
    strErrMsg = Err.Number & ": " & Err.Description
    Err.Clear
    Resume Housekeeping
End Function

' Sort routine - an implementation of BubbleSort
Function BubbleSort2D(varList As Variant, Optional ByVal bolNoCase As Boolean = False, Optional ByVal bolAscending As Boolean = False) As Boolean
    Dim bolDone As Boolean
    Dim bolString As Boolean
    Dim bolDoSwap As Boolean
    Dim lngOuter As Long
    Dim lngInner As Long
    Dim varTemp As Variant
    Dim lngMin As Long
    Dim lngMax As Long
    Dim lngInnerMin As Long
    Dim lngInnerMax As Long
    ' Set bounds.
    lngMin = LBound(varList)
    lngMax = UBound(varList)
    lngInnerMin = LBound(varList, 2)
    lngInnerMax = UBound(varList, 2)
    ReDim varTemp(lngInnerMin To lngInnerMax)
    bolString = (TypeName(varList(lngMin, lngInnerMin)) = "String")
    ' Repeat until the list is sorted.
    Do
        bolDone = True
        For lngOuter = lngMin + 1 To lngMax
            ' Compare items lngOuter - 1 and lngOuter.
            If bolString And bolNoCase Then
                If bolAscending Then
                    bolDoSwap = (UCase(varList(lngOuter - 1, lngInnerMin)) > UCase(varList(lngOuter, lngInnerMin)))
                Else
                    bolDoSwap = (UCase(varList(lngOuter - 1, lngInnerMin)) < UCase(varList(lngOuter, lngInnerMin)))
                End If
            Else
                If bolAscending Then
                    bolDoSwap = (varList(lngOuter - 1, lngInnerMin) > varList(lngOuter, lngInnerMin))
                Else
                    bolDoSwap = (varList(lngOuter - 1, lngInnerMin) < varList(lngOuter, lngInnerMin))
                End If
            End If
            If bolDoSwap Then
                ' Swap them.
                For lngInner = lngInnerMin To lngInnerMax
                    varTemp = varList(lngOuter - 1, lngInner)
                    varList(lngOuter - 1, lngInner) = varList(lngOuter, lngInner)
                    varList(lngOuter, lngInner) = varTemp
                Next
                bolDone = False
            End If
        Next lngOuter
    Loop Until bolDone
End Function