R
Rachel
Hi there!
Is there any code which you can help me with to copy HIDDEN COLUMNS to a new
workbook.
I'm using below codes: (COLUMNS HIDDEN are columns J-K-L)
Sub Copy_With_AutoFilter1()
'Note: This macro use the function LastRow
Dim My_Range As Range
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim WSNew As Worksheet
Dim sheetName As String
Dim rng As Range
Dim WS As Worksheet
Set My_Range = Worksheets("Sheet1").Range("A1:BN" &
LastRow(Worksheets("Sheet1")))
My_Range.Parent.Select
If ActiveWorkbook.ProtectStructure = True Or _
My_Range.Parent.ProtectContents = True Then
ActiveWorkbook.Unprotect ("sda")
End If
ActiveSheet.Unprotect ("sda")
'Change ScreenUpdating, Calculation, EnableEvents, ....
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
'Firstly, remove the AutoFilter
My_Range.Parent.AutoFilterMode = False
'If you want to filter on a Inputbox value use this
FilterCriteria = InputBox("What text do you want to filter on?", _
"Enter the filter item.")
My_Range.autofilter Field:=4, Criteria1:="=" & FilterCriteria
'Check if there are not more then 8192 areas(limit of areas that Excel
can copy)
CCount = 0
On Error Resume Next
CCount =
My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 areas:" _
& vbNewLine & "It is not possible to copy the visible data." _
& vbNewLine & "Tip: Sort your data before you use this macro.", _
vbOKOnly, "Copy to worksheet"
Else
Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
'Ask for the Worksheet name
sheetName = InputBox("What is the name of the new worksheet?", _
"Name the New Sheet")
On Error Resume Next
WSNew.Name = sheetName
If Err.Number > 0 Then
MsgBox "Change the name of sheet : " & WSNew.Name & _
" manually after the macro is ready. The sheet name" & _
" you fill in already exists or you use characters" & _
" that are not allowed in a sheet name."
Err.Clear
End If
On Error GoTo 0
'Copy/paste the visible data to the new worksheet
Selection.EntireColumn.Hidden = False
My_Range.Parent.autofilter.Range.Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
' Remove this line if you use Excel 97
.PasteSpecial Paste:=8
.PasteSpecial xlPasteAll
Application.CutCopyMode = False
.Select
ActiveSheet.Protection.AllowEditRanges.Add Title:="Range1",
Range:=Columns("AS:AX")
End With
Selection.autofilter
ActiveSheet.Protect ("sda")
End If
'Close AutoFilter
My_Range.Parent.AutoFilterMode = False
'Restore ScreenUpdating, Calculation, EnableEvents, ....
ActiveWindow.View = ViewMode
If Not WSNew Is Nothing Then WSNew.Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
My_Range.Parent.Protect Password:="sda"
End Sub
Is there any code which you can help me with to copy HIDDEN COLUMNS to a new
workbook.
I'm using below codes: (COLUMNS HIDDEN are columns J-K-L)
Sub Copy_With_AutoFilter1()
'Note: This macro use the function LastRow
Dim My_Range As Range
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim WSNew As Worksheet
Dim sheetName As String
Dim rng As Range
Dim WS As Worksheet
Set My_Range = Worksheets("Sheet1").Range("A1:BN" &
LastRow(Worksheets("Sheet1")))
My_Range.Parent.Select
If ActiveWorkbook.ProtectStructure = True Or _
My_Range.Parent.ProtectContents = True Then
ActiveWorkbook.Unprotect ("sda")
End If
ActiveSheet.Unprotect ("sda")
'Change ScreenUpdating, Calculation, EnableEvents, ....
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
'Firstly, remove the AutoFilter
My_Range.Parent.AutoFilterMode = False
'If you want to filter on a Inputbox value use this
FilterCriteria = InputBox("What text do you want to filter on?", _
"Enter the filter item.")
My_Range.autofilter Field:=4, Criteria1:="=" & FilterCriteria
'Check if there are not more then 8192 areas(limit of areas that Excel
can copy)
CCount = 0
On Error Resume Next
CCount =
My_Range.Columns(1).SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 areas:" _
& vbNewLine & "It is not possible to copy the visible data." _
& vbNewLine & "Tip: Sort your data before you use this macro.", _
vbOKOnly, "Copy to worksheet"
Else
Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
'Ask for the Worksheet name
sheetName = InputBox("What is the name of the new worksheet?", _
"Name the New Sheet")
On Error Resume Next
WSNew.Name = sheetName
If Err.Number > 0 Then
MsgBox "Change the name of sheet : " & WSNew.Name & _
" manually after the macro is ready. The sheet name" & _
" you fill in already exists or you use characters" & _
" that are not allowed in a sheet name."
Err.Clear
End If
On Error GoTo 0
'Copy/paste the visible data to the new worksheet
Selection.EntireColumn.Hidden = False
My_Range.Parent.autofilter.Range.Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
' Remove this line if you use Excel 97
.PasteSpecial Paste:=8
.PasteSpecial xlPasteAll
Application.CutCopyMode = False
.Select
ActiveSheet.Protection.AllowEditRanges.Add Title:="Range1",
Range:=Columns("AS:AX")
End With
Selection.autofilter
ActiveSheet.Protect ("sda")
End If
'Close AutoFilter
My_Range.Parent.AutoFilterMode = False
'Restore ScreenUpdating, Calculation, EnableEvents, ....
ActiveWindow.View = ViewMode
If Not WSNew Is Nothing Then WSNew.Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
My_Range.Parent.Protect Password:="sda"
End Sub