S
Steve
Hi Guys,
I thought I'd start a new thread since the old was so huge! The code
you provided (Garry, Isabelle, Clif, Charabeuh - Thank you!!) worked
like a charm while I was using Excel 2003. I was just recently
upgraded to Excel 2010, and now the code freezes up (Excel Not
Responding). I stepped through the code, and it appears to me that
the issue lies with the unhiding of hidden columns in the source
sheet. I tried both code sets (distinctly different) with the same
result. Any ideas? Thanks!
Sub Copy_Rows()
Dim wksSource As Worksheet, wksTarget As Worksheet
Dim ColumnsList()
Dim x As Integer, i As Integer
Dim rgVisible As Range
'********************************************************************************
On Error Resume Next
Set columnfilter = Application.InputBox(prompt:= _
"Select Any Cell in Column to Filter On", Type:=8)
If columnfilter Is Nothing Then
blCancelled = True
Exit Sub
End If
On Error GoTo 0
'********************************************************************************
blCancelled = False
On Error Resume Next
Set wksSource = ActiveSheet
UserForm1.Show '//get wksTarget sheetname
Set wksTarget = Sheets(gsWksTargetName)
On Error GoTo 0
If blCancelled Then Exit Sub
'********************************************************************************
Application.ScreenUpdating = False
With wksTarget
.Rows("1:" & CStr(.UsedRange.Rows.Count)).ClearContents
.Rows("1:" & CStr(.UsedRange.Rows.Count)).ClearComments
.Rows("1:" & CStr(.UsedRange.Rows.Count)).Interior.ColorIndex =
xlNone
End With
'*************Unhide Columns Code***************
'1st code set to Unhide
'x = 0
'With wksSource
' For i = 1 To .Columns.Count
' If .Columns(i).Hidden Then
' ReDim Preserve ColumnsList(x): ColumnsList(x) = i
' .Columns(i).Hidden = False: x = x + 1
' End If
' Next i
'End With
'2nd code set to unhide
With wksSource
On Error Resume Next
Set rgVisible = .Rows("1:1").SpecialCells(xlCellTypeVisible)
.Columns.Hidden = False
On Error GoTo 0
End With
'*****************AutoFilter********************
With wksSource
columnfilter.EntireColumn.AutoFilter Field:=1, Criteria1:="Y"
.UsedRange.Copy
wksTarget.Range("1:1").PasteSpecial Paste:=xlPasteColumnWidths
.UsedRange.Copy wksTarget.Range("1:1") '//put the data
columnfilter.EntireColumn.AutoFilter
End With
'*************Hide Columns Code*****************
'1st code set to re hide
' For i = LBound(ColumnsList) To UBound(ColumnsList)
' wksSource.Columns(ColumnsList(i)).Hidden = True
' wksTarget.Columns(ColumnsList(i)).Hidden = True
' Next
'2nd code set to re hide
With wksSource
.Columns.Hidden = True
If Not rgVisible Is Nothing Then _
rgVisible.EntireColumn.Hidden = False
End With
Application.ScreenUpdating = True
End Sub
I thought I'd start a new thread since the old was so huge! The code
you provided (Garry, Isabelle, Clif, Charabeuh - Thank you!!) worked
like a charm while I was using Excel 2003. I was just recently
upgraded to Excel 2010, and now the code freezes up (Excel Not
Responding). I stepped through the code, and it appears to me that
the issue lies with the unhiding of hidden columns in the source
sheet. I tried both code sets (distinctly different) with the same
result. Any ideas? Thanks!
Sub Copy_Rows()
Dim wksSource As Worksheet, wksTarget As Worksheet
Dim ColumnsList()
Dim x As Integer, i As Integer
Dim rgVisible As Range
'********************************************************************************
On Error Resume Next
Set columnfilter = Application.InputBox(prompt:= _
"Select Any Cell in Column to Filter On", Type:=8)
If columnfilter Is Nothing Then
blCancelled = True
Exit Sub
End If
On Error GoTo 0
'********************************************************************************
blCancelled = False
On Error Resume Next
Set wksSource = ActiveSheet
UserForm1.Show '//get wksTarget sheetname
Set wksTarget = Sheets(gsWksTargetName)
On Error GoTo 0
If blCancelled Then Exit Sub
'********************************************************************************
Application.ScreenUpdating = False
With wksTarget
.Rows("1:" & CStr(.UsedRange.Rows.Count)).ClearContents
.Rows("1:" & CStr(.UsedRange.Rows.Count)).ClearComments
.Rows("1:" & CStr(.UsedRange.Rows.Count)).Interior.ColorIndex =
xlNone
End With
'*************Unhide Columns Code***************
'1st code set to Unhide
'x = 0
'With wksSource
' For i = 1 To .Columns.Count
' If .Columns(i).Hidden Then
' ReDim Preserve ColumnsList(x): ColumnsList(x) = i
' .Columns(i).Hidden = False: x = x + 1
' End If
' Next i
'End With
'2nd code set to unhide
With wksSource
On Error Resume Next
Set rgVisible = .Rows("1:1").SpecialCells(xlCellTypeVisible)
.Columns.Hidden = False
On Error GoTo 0
End With
'*****************AutoFilter********************
With wksSource
columnfilter.EntireColumn.AutoFilter Field:=1, Criteria1:="Y"
.UsedRange.Copy
wksTarget.Range("1:1").PasteSpecial Paste:=xlPasteColumnWidths
.UsedRange.Copy wksTarget.Range("1:1") '//put the data
columnfilter.EntireColumn.AutoFilter
End With
'*************Hide Columns Code*****************
'1st code set to re hide
' For i = LBound(ColumnsList) To UBound(ColumnsList)
' wksSource.Columns(ColumnsList(i)).Hidden = True
' wksTarget.Columns(ColumnsList(i)).Hidden = True
' Next
'2nd code set to re hide
With wksSource
.Columns.Hidden = True
If Not rgVisible Is Nothing Then _
rgVisible.EntireColumn.Hidden = False
End With
Application.ScreenUpdating = True
End Sub