CODEWITHSUNDEEP
excelvbarowhidden
joey
joey

Reputation: 47

How can I edit the following Copysheets macro to NOT copy hidden columns/rows?

I have a macro that we use for copying a worksheet into a new workbook. The only issue I am having is that when it copies the worksheet into a new workbook, it copies the hidden columns/rows. What would be the best way to update the macro so that it doesn't copy the hidden columns/rows?

Sub CopySheets()
    Dim wkb As Excel.Workbook
    Dim newWkb As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim newWks As Excel.Worksheet
    Dim sheets As Variant
    Dim varName As Variant
    Dim i As Integer
    '------------------------------------------------------------
    Application.ScreenUpdating = False

    'Define the names of worksheets to be copied.
    sheets = VBA.Array("TAB NAME")


    'Create reference to the current Excel workbook and to the destination workbook.
    Set wkb = Excel.ThisWorkbook
    Set newWkb = Excel.Workbooks.Add


    For Each varName In sheets

        'Clear reference to the [wks] variable.
        Set wks = Nothing

        'Check if there is a worksheet with such name.
        On Error Resume Next
        Set wks = wkb.Worksheets(VBA.CStr(varName))
        On Error GoTo 0


        'If worksheet with such name is not found, those instructions are skipped.
        If Not wks Is Nothing Then

            'Copy this worksheet to a new workbook.
            Call wks.Copy(newWkb.Worksheets(1))

            'Get the reference to the copy of this worksheet and paste
            'all its content as values.
            Set newWks = newWkb.Worksheets(wks.Name)
            With newWks
                Call .Cells.Copy
                Call .Range("A1").PasteSpecial(Paste:=xlValues)
                Call .Range("A1").Select
            End With

        End If
        
        'Delete Sheet1 from new workbook    
    Application.DisplayAlerts = False
        For i = newWkb.Worksheets.Count To 2 Step -1
        newWkb.Worksheets(i).Delete
        Next i
    Application.DisplayAlerts = True

    Next varName
    
    Application.ScreenUpdating = True
End Sub

Upvotes: 2

Views: 57

Answers (2)

Tim Williams
Tim Williams

Reputation: 166755

Something like this should work:

Sub CopySheets()
    
    Dim wkb As Workbook   'you don't typically use the `Excel.` prefix....
    Dim newWkb As Workbook
    Dim wks As Worksheet
    Dim newWks As Worksheet
    Dim sheetsToCopy As Variant, varName As Variant, copied As Long
    
    Application.ScreenUpdating = False

    sheetsToCopy = VBA.Array("TAB NAME") 'worksheets to be copied.

    Set wkb = ThisWorkbook
    Set newWkb = Excel.Workbooks.Add '#ADDED
    
    For Each varName In sheetsToCopy
        Set wks = Nothing
        
        On Error Resume Next 'is there a worksheet with this name?
        Set wks = wkb.Worksheets(VBA.CStr(varName))
        On Error GoTo 0
        
        If Not wks Is Nothing Then
            wks.Copy before:=newWkb.Worksheets(1)  'use of `Call` is deprecated...
            Set newWks = newWkb.Worksheets(1)
            newWks.UsedRange.Value = newWks.UsedRange.Value 'convert to values
            DeleteHiddenColsAndRows newWks                  'remove hidden rows/columns
            copied = copied + 1
            If copied = 1 Then 'remove existing sheet after first copy is made
                Application.DisplayAlerts = False
                newWkb.Worksheets(2).Delete
                Application.DisplayAlerts = True
            End If
        End If
    Next varName
    
    Application.ScreenUpdating = True
    
    MsgBox copied & " worksheets were copied", vbInformation + vbOKOnly
End Sub

Sub DeleteHiddenColsAndRows(ws As Worksheet)
    Dim rng As Range, rw As Range, col As Range
    'loop columns
    For Each col In ws.UsedRange.Columns
        If col.EntireColumn.Hidden Then BuildRange rng, col.EntireColumn
    Next col
    If Not rng Is Nothing Then rng.Delete 'deleting in a batch is faster
    'loop rows
    Set rng = Nothing 'reset range
    For Each rw In ws.UsedRange.Rows
        If rw.EntireRow.Hidden Then BuildRange rng, rw.EntireRow
    Next rw
    If Not rng Is Nothing Then rng.Delete
End Sub

'build a range in `rngTot` by adding range `rngAdd`
Sub BuildRange(ByRef rngTot As Range, rngAdd As Range)
    If rngTot Is Nothing Then
        Set rngTot = rngAdd
    Else
        Set rngTot = Application.Union(rngTot, rngAdd)
    End If
End Sub

Upvotes: 1

VBasic2008
VBasic2008

Reputation: 54898

Exclude Hidden Rows When Pasting

  • Try the following. Not tested!
        Dim nrg As Range
        Dim nRowsCount As Long

        Set newWks = newWkb.Worksheets(wks. Name)

        With newWks.UsedRange
            Set nrg = .SpecialCells(xlCellTypeVisible)
            nRowsCount = Intersect(nrg, newWks.Columns(nrg.Column)).Cells.Count
            nrg.Copy
            .Range("A1").PasteSpecial Paste:=xlValues
            .Resize(.Rows.Count - nRowsCount).Offset(nRowsCount).Clear
            Application.Goto .Range("A1")
        End With
  • BTW, .Sheets is a workbook property. A better and more readable variable name (instead of sheets) would be SheetNames.

Upvotes: 1

Related Questions