Autofilter in 1 workbook and paste in 2nd workbook

M

Mountaineer

Hi,

I'm want to autofilter in "Master.xls" sheet1 and paste the results to the
bottom of existing "Current.xls" sheet1. I found a macro by Ron de Bruin
that works if pasting to a worksheet in the same workbook. I tried to modify
it but have not had any luck.


Dim My_Range As Range
Dim DestSh As Worksheet
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim rng As Range

'set filter ranger on Sheet 1 of Master.xls
Windows("Master.xls").Activate
Set My_Range = Worksheets("sheet1").Range("A2:H" &
LastRow(Worksheets("Sheet1")))
My_Range.Parent.Select

'set the destination worksheet. This is where it bombs!

Set DestSh = Worksheets("[Current.xls]sheet1")

'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


'Filter and set the filter field and filter criteria:

My_Range.AutoFilter Field:=1, Criteria1:="=3015"

'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
'Copy the visible data and use PasteSpecial to paste to the Desth

With My_Range.Parent.AutoFilter.Range
On Error Resume Next
'Set rng to the visible cells in My_Range without the header row
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
'copy and paste the cells into Destsh below the existing data
rng.Copy
With DestSh.Range("A" & LastRow(DestSh) + 1)
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False

End With
End If
End With
End If

'close autofilter

My_Range.Parent.AutoFilterMode = False

'Restore screenupdating, calculation, enableevents...

ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("a2")

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode

End With

End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(what:="*", _
After:=sh.Range("a2"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
 
R

r

Set DestSh = Worksheets("[Current.xls]sheet1")

Set DestSh = Workbooks("Current").Worksheets("sheet1")

regards
r



Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


Mountaineer said:
Hi,

I'm want to autofilter in "Master.xls" sheet1 and paste the results to the
bottom of existing "Current.xls" sheet1. I found a macro by Ron de Bruin
that works if pasting to a worksheet in the same workbook. I tried to modify
it but have not had any luck.


Dim My_Range As Range
Dim DestSh As Worksheet
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim rng As Range

'set filter ranger on Sheet 1 of Master.xls
Windows("Master.xls").Activate
Set My_Range = Worksheets("sheet1").Range("A2:H" &
LastRow(Worksheets("Sheet1")))
My_Range.Parent.Select

'set the destination worksheet. This is where it bombs!

Set DestSh = Worksheets("[Current.xls]sheet1")

'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


'Filter and set the filter field and filter criteria:

My_Range.AutoFilter Field:=1, Criteria1:="=3015"

'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
'Copy the visible data and use PasteSpecial to paste to the Desth

With My_Range.Parent.AutoFilter.Range
On Error Resume Next
'Set rng to the visible cells in My_Range without the header row
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
'copy and paste the cells into Destsh below the existing data
rng.Copy
With DestSh.Range("A" & LastRow(DestSh) + 1)
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False

End With
End If
End With
End If

'close autofilter

My_Range.Parent.AutoFilterMode = False

'Restore screenupdating, calculation, enableevents...

ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("a2")

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode

End With

End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(what:="*", _
After:=sh.Range("a2"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Click to expand...
 
M

Mountaineer

Thank you for such a quick response.

I now get a compile error:Sub or Function not defined. "Wookbooks" gets
highlighted.
--
Thank you!!

Mountaineer


r said:
Set DestSh = Worksheets("[Current.xls]sheet1")
Click to expand...

Set DestSh = Workbooks("Current").Worksheets("sheet1")

regards
r



Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


Mountaineer said:
Hi,

I'm want to autofilter in "Master.xls" sheet1 and paste the results to the
bottom of existing "Current.xls" sheet1. I found a macro by Ron de Bruin
that works if pasting to a worksheet in the same workbook. I tried to modify
it but have not had any luck.


Dim My_Range As Range
Dim DestSh As Worksheet
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim rng As Range

'set filter ranger on Sheet 1 of Master.xls
Windows("Master.xls").Activate
Set My_Range = Worksheets("sheet1").Range("A2:H" &
LastRow(Worksheets("Sheet1")))
My_Range.Parent.Select

'set the destination worksheet. This is where it bombs!

Set DestSh = Worksheets("[Current.xls]sheet1")

'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


'Filter and set the filter field and filter criteria:

My_Range.AutoFilter Field:=1, Criteria1:="=3015"

'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
'Copy the visible data and use PasteSpecial to paste to the Desth

With My_Range.Parent.AutoFilter.Range
On Error Resume Next
'Set rng to the visible cells in My_Range without the header row
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
'copy and paste the cells into Destsh below the existing data
rng.Copy
With DestSh.Range("A" & LastRow(DestSh) + 1)
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False

End With
End If
End With
End If

'close autofilter

My_Range.Parent.AutoFilterMode = False

'Restore screenupdating, calculation, enableevents...

ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("a2")

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode

End With

End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(what:="*", _
After:=sh.Range("a2"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Click to expand...
Click to expand...
 
R

r

Workbooks

regards
r

Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


Mountaineer said:
Thank you for such a quick response.

I now get a compile error:Sub or Function not defined. "Wookbooks" gets
highlighted.
--
Thank you!!

Mountaineer


r said:
Set DestSh = Worksheets("[Current.xls]sheet1")
Click to expand...

Set DestSh = Workbooks("Current").Worksheets("sheet1")

regards
r



Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


Mountaineer said:
Hi,

I'm want to autofilter in "Master.xls" sheet1 and paste the results to the
bottom of existing "Current.xls" sheet1. I found a macro by Ron de Bruin
that works if pasting to a worksheet in the same workbook. I tried to modify
it but have not had any luck.


Dim My_Range As Range
Dim DestSh As Worksheet
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim rng As Range

'set filter ranger on Sheet 1 of Master.xls
Windows("Master.xls").Activate
Set My_Range = Worksheets("sheet1").Range("A2:H" &
LastRow(Worksheets("Sheet1")))
My_Range.Parent.Select

'set the destination worksheet. This is where it bombs!

Set DestSh = Worksheets("[Current.xls]sheet1")

'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


'Filter and set the filter field and filter criteria:

My_Range.AutoFilter Field:=1, Criteria1:="=3015"

'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
'Copy the visible data and use PasteSpecial to paste to the Desth

With My_Range.Parent.AutoFilter.Range
On Error Resume Next
'Set rng to the visible cells in My_Range without the header row
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
'copy and paste the cells into Destsh below the existing data
rng.Copy
With DestSh.Range("A" & LastRow(DestSh) + 1)
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False

End With
End If
End With
End If

'close autofilter

My_Range.Parent.AutoFilterMode = False

'Restore screenupdating, calculation, enableevents...

ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("a2")

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode

End With

End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(what:="*", _
After:=sh.Range("a2"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Click to expand...
Click to expand...
Click to expand...
 
M

Mountaineer

I am so embarrassed. I fixed my misspelling. Now I get "subscript out of
range" still at the same place "Set Destsh...."

Thank you for your patience.


--
Thank you!!

Mountaineer


r said:
Workbooks

regards
r

Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


Mountaineer said:
Thank you for such a quick response.

I now get a compile error:Sub or Function not defined. "Wookbooks" gets
highlighted.
--
Thank you!!

Mountaineer


r said:
Set DestSh = Worksheets("[Current.xls]sheet1")

Set DestSh = Workbooks("Current").Worksheets("sheet1")

regards
r



Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


:

Hi,

I'm want to autofilter in "Master.xls" sheet1 and paste the results to the
bottom of existing "Current.xls" sheet1. I found a macro by Ron de Bruin
that works if pasting to a worksheet in the same workbook. I tried to modify
it but have not had any luck.


Dim My_Range As Range
Dim DestSh As Worksheet
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim rng As Range

'set filter ranger on Sheet 1 of Master.xls
Windows("Master.xls").Activate
Set My_Range = Worksheets("sheet1").Range("A2:H" &
LastRow(Worksheets("Sheet1")))
My_Range.Parent.Select

'set the destination worksheet. This is where it bombs!

Set DestSh = Worksheets("[Current.xls]sheet1")

'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


'Filter and set the filter field and filter criteria:

My_Range.AutoFilter Field:=1, Criteria1:="=3015"

'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
'Copy the visible data and use PasteSpecial to paste to the Desth

With My_Range.Parent.AutoFilter.Range
On Error Resume Next
'Set rng to the visible cells in My_Range without the header row
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
'copy and paste the cells into Destsh below the existing data
rng.Copy
With DestSh.Range("A" & LastRow(DestSh) + 1)
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False

End With
End If
End With
End If

'close autofilter

My_Range.Parent.AutoFilterMode = False

'Restore screenupdating, calculation, enableevents...

ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("a2")

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode

End With

End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(what:="*", _
After:=sh.Range("a2"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Click to expand...
Click to expand...
Click to expand...
 
P

Patrick Molloy

make sure that the name of the destination workbook and worksheet are
correct and that it is open

Mountaineer said:
I am so embarrassed. I fixed my misspelling. Now I get "subscript out of
range" still at the same place "Set Destsh...."

Thank you for your patience.


--
Thank you!!

Mountaineer


r said:
Workbooks

regards
r

Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


Mountaineer said:
Thank you for such a quick response.

I now get a compile error:Sub or Function not defined. "Wookbooks"
gets
highlighted.
--
Thank you!!

Mountaineer


:

Set DestSh = Worksheets("[Current.xls]sheet1")

Set DestSh = Workbooks("Current").Worksheets("sheet1")

regards
r



Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


:

Hi,

I'm want to autofilter in "Master.xls" sheet1 and paste the results
to the
bottom of existing "Current.xls" sheet1. I found a macro by Ron de
Bruin
that works if pasting to a worksheet in the same workbook. I tried
to modify
it but have not had any luck.


Dim My_Range As Range
Dim DestSh As Worksheet
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim rng As Range

'set filter ranger on Sheet 1 of Master.xls
Windows("Master.xls").Activate
Set My_Range = Worksheets("sheet1").Range("A2:H" &
LastRow(Worksheets("Sheet1")))
My_Range.Parent.Select

'set the destination worksheet. This is where it bombs!

Set DestSh = Worksheets("[Current.xls]sheet1")

'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


'Filter and set the filter field and filter criteria:

My_Range.AutoFilter Field:=1, Criteria1:="=3015"

'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
'Copy the visible data and use PasteSpecial to paste to the
Desth

With My_Range.Parent.AutoFilter.Range
On Error Resume Next
'Set rng to the visible cells in My_Range without the header
row
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
_
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
'copy and paste the cells into Destsh below the existing data
rng.Copy
With DestSh.Range("A" & LastRow(DestSh) + 1)
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False

End With
End If
End With
End If

'close autofilter

My_Range.Parent.AutoFilterMode = False

'Restore screenupdating, calculation, enableevents...

ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("a2")

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode

End With

End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(what:="*", _
After:=sh.Range("a2"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Click to expand...
Click to expand...
Click to expand...
 
M

Mountaineer

Hi,

I made sure both "Current" and "Master" spreadsheets are open. Below is a
"copy" since I don't trust my spelling. I am still getting the "Subscript
out of range" error. Is it possible it's because I don't have anything DIM
as a workbook?

thanks for your help.


Set DestSh = Workbooks("Current").Worksheets("Sheet1")
--
Thank you!!

Mountaineer


Patrick Molloy said:
make sure that the name of the destination workbook and worksheet are
correct and that it is open

Mountaineer said:
I am so embarrassed. I fixed my misspelling. Now I get "subscript out of
range" still at the same place "Set Destsh...."

Thank you for your patience.


--
Thank you!!

Mountaineer


r said:
Workbooks

regards
r

Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


:

Thank you for such a quick response.

I now get a compile error:Sub or Function not defined. "Wookbooks"
gets
highlighted.
--
Thank you!!

Mountaineer


:

Set DestSh = Worksheets("[Current.xls]sheet1")

Set DestSh = Workbooks("Current").Worksheets("sheet1")

regards
r



Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


:

Hi,

I'm want to autofilter in "Master.xls" sheet1 and paste the results
to the
bottom of existing "Current.xls" sheet1. I found a macro by Ron de
Bruin
that works if pasting to a worksheet in the same workbook. I tried
to modify
it but have not had any luck.


Dim My_Range As Range
Dim DestSh As Worksheet
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim rng As Range

'set filter ranger on Sheet 1 of Master.xls
Windows("Master.xls").Activate
Set My_Range = Worksheets("sheet1").Range("A2:H" &
LastRow(Worksheets("Sheet1")))
My_Range.Parent.Select

'set the destination worksheet. This is where it bombs!

Set DestSh = Worksheets("[Current.xls]sheet1")

'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


'Filter and set the filter field and filter criteria:

My_Range.AutoFilter Field:=1, Criteria1:="=3015"

'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
'Copy the visible data and use PasteSpecial to paste to the
Desth

With My_Range.Parent.AutoFilter.Range
On Error Resume Next
'Set rng to the visible cells in My_Range without the header
row
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
_
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
'copy and paste the cells into Destsh below the existing data
rng.Copy
With DestSh.Range("A" & LastRow(DestSh) + 1)
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False

End With
End If
End With
End If

'close autofilter

My_Range.Parent.AutoFilterMode = False

'Restore screenupdating, calculation, enableevents...

ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("a2")

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode

End With

End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(what:="*", _
After:=sh.Range("a2"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Click to expand...
Click to expand...
Click to expand...
 
P

Patrick Molloy

probably needs the .xls extension

Set DestSh = Workbooks("Current.xls").Worksheets("Sheet1")




Mountaineer said:
Hi,

I made sure both "Current" and "Master" spreadsheets are open. Below is a
"copy" since I don't trust my spelling. I am still getting the "Subscript
out of range" error. Is it possible it's because I don't have anything
DIM
as a workbook?

thanks for your help.


Set DestSh = Workbooks("Current").Worksheets("Sheet1")
--
Thank you!!

Mountaineer


Patrick Molloy said:
make sure that the name of the destination workbook and worksheet are
correct and that it is open

Mountaineer said:
I am so embarrassed. I fixed my misspelling. Now I get "subscript out
of
range" still at the same place "Set Destsh...."

Thank you for your patience.


--
Thank you!!

Mountaineer


:

Workbooks

regards
r

Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


:

Thank you for such a quick response.

I now get a compile error:Sub or Function not defined. "Wookbooks"
gets
highlighted.
--
Thank you!!

Mountaineer


:

Set DestSh = Worksheets("[Current.xls]sheet1")

Set DestSh = Workbooks("Current").Worksheets("sheet1")

regards
r



Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


:

Hi,

I'm want to autofilter in "Master.xls" sheet1 and paste the
results
to the
bottom of existing "Current.xls" sheet1. I found a macro by Ron
de
Bruin
that works if pasting to a worksheet in the same workbook. I
tried
to modify
it but have not had any luck.


Dim My_Range As Range
Dim DestSh As Worksheet
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim rng As Range

'set filter ranger on Sheet 1 of Master.xls
Windows("Master.xls").Activate
Set My_Range = Worksheets("sheet1").Range("A2:H" &
LastRow(Worksheets("Sheet1")))
My_Range.Parent.Select

'set the destination worksheet. This is where it bombs!

Set DestSh = Worksheets("[Current.xls]sheet1")

'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


'Filter and set the filter field and filter criteria:

My_Range.AutoFilter Field:=1, Criteria1:="=3015"

'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
'Copy the visible data and use PasteSpecial to paste to the
Desth

With My_Range.Parent.AutoFilter.Range
On Error Resume Next
'Set rng to the visible cells in My_Range without the header
row
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1,
.Columns.Count)
_
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
'copy and paste the cells into Destsh below the existing
data
rng.Copy
With DestSh.Range("A" & LastRow(DestSh) + 1)
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False

End With
End If
End With
End If

'close autofilter

My_Range.Parent.AutoFilterMode = False

'Restore screenupdating, calculation, enableevents...

ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("a2")

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode

End With

End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(what:="*", _
After:=sh.Range("a2"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Click to expand...
Click to expand...
Click to expand...
 
M

Mountaineer

Hi Patrick,

Sorry...that didn't work. I now get a "type mismatch" error.

Set DestSh = Workbooks("Current.xls").Worksheets("Sheet1")
--
Thank you!!

Mountaineer


Patrick Molloy said:
probably needs the .xls extension

Set DestSh = Workbooks("Current.xls").Worksheets("Sheet1")




Mountaineer said:
Hi,

I made sure both "Current" and "Master" spreadsheets are open. Below is a
"copy" since I don't trust my spelling. I am still getting the "Subscript
out of range" error. Is it possible it's because I don't have anything
DIM
as a workbook?

thanks for your help.


Set DestSh = Workbooks("Current").Worksheets("Sheet1")
--
Thank you!!

Mountaineer


Patrick Molloy said:
make sure that the name of the destination workbook and worksheet are
correct and that it is open

I am so embarrassed. I fixed my misspelling. Now I get "subscript out
of
range" still at the same place "Set Destsh...."

Thank you for your patience.


--
Thank you!!

Mountaineer


:

Workbooks

regards
r

Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


:

Thank you for such a quick response.

I now get a compile error:Sub or Function not defined. "Wookbooks"
gets
highlighted.
--
Thank you!!

Mountaineer


:

Set DestSh = Worksheets("[Current.xls]sheet1")

Set DestSh = Workbooks("Current").Worksheets("sheet1")

regards
r



Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


:

Hi,

I'm want to autofilter in "Master.xls" sheet1 and paste the
results
to the
bottom of existing "Current.xls" sheet1. I found a macro by Ron
de
Bruin
that works if pasting to a worksheet in the same workbook. I
tried
to modify
it but have not had any luck.


Dim My_Range As Range
Dim DestSh As Worksheet
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim rng As Range

'set filter ranger on Sheet 1 of Master.xls
Windows("Master.xls").Activate
Set My_Range = Worksheets("sheet1").Range("A2:H" &
LastRow(Worksheets("Sheet1")))
My_Range.Parent.Select

'set the destination worksheet. This is where it bombs!

Set DestSh = Worksheets("[Current.xls]sheet1")

'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


'Filter and set the filter field and filter criteria:

My_Range.AutoFilter Field:=1, Criteria1:="=3015"

'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
'Copy the visible data and use PasteSpecial to paste to the
Desth

With My_Range.Parent.AutoFilter.Range
On Error Resume Next
'Set rng to the visible cells in My_Range without the header
row
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1,
.Columns.Count)
_
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
'copy and paste the cells into Destsh below the existing
data
rng.Copy
With DestSh.Range("A" & LastRow(DestSh) + 1)
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False

End With
End If
End With
End If

'close autofilter

My_Range.Parent.AutoFilterMode = False

'Restore screenupdating, calculation, enableevents...

ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("a2")

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode

End With

End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(what:="*", _
After:=sh.Range("a2"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Click to expand...
Click to expand...
Click to expand...
 
P

Patrick Molloy

do you have

DIM DestSh As Worksheet

does the workbook called Current.xls have a sheet named Sheet1 ?

Mountaineer said:
Hi Patrick,

Sorry...that didn't work. I now get a "type mismatch" error.

Set DestSh = Workbooks("Current.xls").Worksheets("Sheet1")
--
Thank you!!

Mountaineer


Patrick Molloy said:
probably needs the .xls extension

Set DestSh = Workbooks("Current.xls").Worksheets("Sheet1")




Mountaineer said:
Hi,

I made sure both "Current" and "Master" spreadsheets are open. Below
is a
"copy" since I don't trust my spelling. I am still getting the
"Subscript
out of range" error. Is it possible it's because I don't have anything
DIM
as a workbook?

thanks for your help.


Set DestSh = Workbooks("Current").Worksheets("Sheet1")
--
Thank you!!

Mountaineer


:

make sure that the name of the destination workbook and worksheet are
correct and that it is open

I am so embarrassed. I fixed my misspelling. Now I get "subscript
out
of
range" still at the same place "Set Destsh...."

Thank you for your patience.


--
Thank you!!

Mountaineer


:

Workbooks

regards
r

Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


:

Thank you for such a quick response.

I now get a compile error:Sub or Function not defined.
"Wookbooks"
gets
highlighted.
--
Thank you!!

Mountaineer


:

Set DestSh = Worksheets("[Current.xls]sheet1")

Set DestSh = Workbooks("Current").Worksheets("sheet1")

regards
r



Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


:

Hi,

I'm want to autofilter in "Master.xls" sheet1 and paste the
results
to the
bottom of existing "Current.xls" sheet1. I found a macro by
Ron
de
Bruin
that works if pasting to a worksheet in the same workbook. I
tried
to modify
it but have not had any luck.


Dim My_Range As Range
Dim DestSh As Worksheet
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim rng As Range

'set filter ranger on Sheet 1 of Master.xls
Windows("Master.xls").Activate
Set My_Range = Worksheets("sheet1").Range("A2:H" &
LastRow(Worksheets("Sheet1")))
My_Range.Parent.Select

'set the destination worksheet. This is where it bombs!

Set DestSh = Worksheets("[Current.xls]sheet1")

'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


'Filter and set the filter field and filter criteria:

My_Range.AutoFilter Field:=1, Criteria1:="=3015"

'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
'Copy the visible data and use PasteSpecial to paste to
the
Desth

With My_Range.Parent.AutoFilter.Range
On Error Resume Next
'Set rng to the visible cells in My_Range without the
header
row
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1,
.Columns.Count)
_
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
'copy and paste the cells into Destsh below the
existing
data
rng.Copy
With DestSh.Range("A" & LastRow(DestSh) + 1)
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False

End With
End If
End With
End If

'close autofilter

My_Range.Parent.AutoFilterMode = False

'Restore screenupdating, calculation, enableevents...

ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("a2")

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode

End With

End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(what:="*", _
After:=sh.Range("a2"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Click to expand...
Click to expand...
Click to expand...
 
M

Mountaineer

Hi Patrick,

That's it!! I had

DIM DestSH as Worksheets.

Once I changed it to "Worksheet" and used your other correction "adding the
..xls", it worked fine. Thank you very much.
--
Thank you!!

Mountaineer


Patrick Molloy said:
do you have

DIM DestSh As Worksheet

does the workbook called Current.xls have a sheet named Sheet1 ?

Mountaineer said:
Hi Patrick,

Sorry...that didn't work. I now get a "type mismatch" error.

Set DestSh = Workbooks("Current.xls").Worksheets("Sheet1")
--
Thank you!!

Mountaineer


Patrick Molloy said:
probably needs the .xls extension

Set DestSh = Workbooks("Current.xls").Worksheets("Sheet1")




Hi,

I made sure both "Current" and "Master" spreadsheets are open. Below
is a
"copy" since I don't trust my spelling. I am still getting the
"Subscript
out of range" error. Is it possible it's because I don't have anything
DIM
as a workbook?

thanks for your help.


Set DestSh = Workbooks("Current").Worksheets("Sheet1")
--
Thank you!!

Mountaineer


:

make sure that the name of the destination workbook and worksheet are
correct and that it is open

I am so embarrassed. I fixed my misspelling. Now I get "subscript
out
of
range" still at the same place "Set Destsh...."

Thank you for your patience.


--
Thank you!!

Mountaineer


:

Workbooks

regards
r

Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


:

Thank you for such a quick response.

I now get a compile error:Sub or Function not defined.
"Wookbooks"
gets
highlighted.
--
Thank you!!

Mountaineer


:

Set DestSh = Worksheets("[Current.xls]sheet1")

Set DestSh = Workbooks("Current").Worksheets("sheet1")

regards
r



Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


:

Hi,

I'm want to autofilter in "Master.xls" sheet1 and paste the
results
to the
bottom of existing "Current.xls" sheet1. I found a macro by
Ron
de
Bruin
that works if pasting to a worksheet in the same workbook. I
tried
to modify
it but have not had any luck.


Dim My_Range As Range
Dim DestSh As Worksheet
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim rng As Range

'set filter ranger on Sheet 1 of Master.xls
Windows("Master.xls").Activate
Set My_Range = Worksheets("sheet1").Range("A2:H" &
LastRow(Worksheets("Sheet1")))
My_Range.Parent.Select

'set the destination worksheet. This is where it bombs!

Set DestSh = Worksheets("[Current.xls]sheet1")

'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


'Filter and set the filter field and filter criteria:

My_Range.AutoFilter Field:=1, Criteria1:="=3015"

'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
'Copy the visible data and use PasteSpecial to paste to
the
Desth

With My_Range.Parent.AutoFilter.Range
On Error Resume Next
'Set rng to the visible cells in My_Range without the
header
row
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1,
.Columns.Count)
_
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
'copy and paste the cells into Destsh below the
existing
data
rng.Copy
With DestSh.Range("A" & LastRow(DestSh) + 1)
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False

End With
End If
End With
End If

'close autofilter

My_Range.Parent.AutoFilterMode = False

'Restore screenupdating, calculation, enableevents...

ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("a2")

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode

End With

End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(what:="*", _
After:=sh.Range("a2"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Click to expand...
Click to expand...
Click to expand...
 
P

Patrick Molloy

phewee :)

Mountaineer said:
Hi Patrick,

That's it!! I had

DIM DestSH as Worksheets.

Once I changed it to "Worksheet" and used your other correction "adding
the
.xls", it worked fine. Thank you very much.
--
Thank you!!

Mountaineer


Patrick Molloy said:
do you have

DIM DestSh As Worksheet

does the workbook called Current.xls have a sheet named Sheet1 ?

Mountaineer said:
Hi Patrick,

Sorry...that didn't work. I now get a "type mismatch" error.

Set DestSh = Workbooks("Current.xls").Worksheets("Sheet1")
--
Thank you!!

Mountaineer


:

probably needs the .xls extension

Set DestSh = Workbooks("Current.xls").Worksheets("Sheet1")




Hi,

I made sure both "Current" and "Master" spreadsheets are open.
Below
is a
"copy" since I don't trust my spelling. I am still getting the
"Subscript
out of range" error. Is it possible it's because I don't have
anything
DIM
as a workbook?

thanks for your help.


Set DestSh = Workbooks("Current").Worksheets("Sheet1")
--
Thank you!!

Mountaineer


:

make sure that the name of the destination workbook and worksheet
are
correct and that it is open

message
I am so embarrassed. I fixed my misspelling. Now I get
"subscript
out
of
range" still at the same place "Set Destsh...."

Thank you for your patience.


--
Thank you!!

Mountaineer


:

Workbooks

regards
r

Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


:

Thank you for such a quick response.

I now get a compile error:Sub or Function not defined.
"Wookbooks"
gets
highlighted.
--
Thank you!!

Mountaineer


:

Set DestSh = Worksheets("[Current.xls]sheet1")

Set DestSh = Workbooks("Current").Worksheets("sheet1")

regards
r



Il mio ultimo lavoro ...
http://excelvba.altervista.org/blog/index.php/Excel-VBA/UsedRange-eccezioni-e-alternative.html


:

Hi,

I'm want to autofilter in "Master.xls" sheet1 and paste
the
results
to the
bottom of existing "Current.xls" sheet1. I found a macro
by
Ron
de
Bruin
that works if pasting to a worksheet in the same workbook.
I
tried
to modify
it but have not had any luck.


Dim My_Range As Range
Dim DestSh As Worksheet
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim rng As Range

'set filter ranger on Sheet 1 of Master.xls
Windows("Master.xls").Activate
Set My_Range = Worksheets("sheet1").Range("A2:H" &
LastRow(Worksheets("Sheet1")))
My_Range.Parent.Select

'set the destination worksheet. This is where it
bombs!

Set DestSh = Worksheets("[Current.xls]sheet1")

'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


'Filter and set the filter field and filter criteria:

My_Range.AutoFilter Field:=1, Criteria1:="=3015"

'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
'Copy the visible data and use PasteSpecial to paste
to
the
Desth

With My_Range.Parent.AutoFilter.Range
On Error Resume Next
'Set rng to the visible cells in My_Range without the
header
row
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1,
.Columns.Count)
_
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
'copy and paste the cells into Destsh below the
existing
data
rng.Copy
With DestSh.Range("A" & LastRow(DestSh) + 1)
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False

End With
End If
End With
End If

'close autofilter

My_Range.Parent.AutoFilterMode = False

'Restore screenupdating, calculation, enableevents...

ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("a2")

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode

End With

End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(what:="*", _
After:=sh.Range("a2"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Click to expand...
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Copy HIDDEN columns to a new workbook 3
Modify RDB's Copy filtered data code to loop through multiple shee 5
Autofilter & copy results to new worksheet 0
Autofilter with criteria from userform 2
copy data from a hidden column to another sheet 1
Autofiltering & copying results to new worksheet - custom message box 0
Help with this macro 6
Private Sub Workbook_NewSheet not firing when new sheet created fromcode 2

Top