• If you would like to post, please check out the MrExcel Message Board FAQ and register here. If you forgot your password, you can reset your password.
  • Excel articles and downloadable files provided in the articles have not been reviewed by MrExcel Publishing. Please apply the provided methods / codes and open the files at your own risk. If you have any questions regarding an article, please use the Article Discussion section.
CephasOz

Copy visible cells to visible cells

Excel Version
  1. 365
  2. 2021
  3. 2019
  4. 2016
  5. 2013
  6. 2011
  7. 2010
  8. 2007
Looking through the Excel articles, I was inspired by the article by Akuini Excel VBA: easy way to paste to visible cells. My code below takes into account hidden rows and columns in both source and destination. It also ensures that overlapping cells of source and destination are not copied; it will copy as much as it can, so cells that don't overlap are copied and cells that do are ignored. So you can actually do a partial copy by deliberately overlapping part of the source with part of the destination, knowing that the source will not be overwritten. If the source and destination ranges are the same, then nothing is copied.
To hold the list of source cells, the copy routine uses a 2D array which has to be sorted, so I will also include the code that I use for the sorting. If you prefer a different procedure for 2D sorting, simply replace it in the code.
The copy routine is written as a function so that it can run and then return success/failure. (Personally, I think Subs should be banned, because you don't know if they were successful or not, whereas with a Function you have that option.)
As @Akuini suggested for their procedure, this procedure can be used in a PERSONAL.XLSB if needed frequently.
The copy routine:
VBA Code:
' 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
The 2D sort:
VBA Code:
' 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
Author
CephasOz
Views
380
First release
Last update
Rating
0.00 star(s) 0 ratings

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top