Paste Filtered Range to New Workbook- AS

[andiam24]

Hello,

I recorded a macro and additionally used the DG help to construct the
following macro; however, I'm not certain how to copy the filtered range
(which will vary every time the worksheet is used) or how to find the last
row of the workbook to which the data will be pasted. Any help would be
great! And thanks in advance.

Sub Macro1()
Dim wbname As String
Dim copyrange As Range
Dim LastRow As Range
Dim rng As Range

' Macro1 Macro
' Macro recorded 12/8/2009 by asagay
'
wbname = ActiveSheet.Range("g1").Value & ActiveSheet.Range("j1").Value
Columns("A:F").Select
Range("F1").Activate
Selection.EntireColumn.Hidden = False
Rows("113:113").Select
Selection.AutoFilter Field:=1, Criteria1:=ActiveSheet.Range("j1").Value
Set rng = ActiveSheet.AutoFilter.Range
If rng.Columns(1).SpecialCells(xlVisible).Count > 1 Then
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Set copyrange = Rows("2:" & LastRow)
copyrange.Copy
End If
Workbooks.Open ("C:\Documents and
Settings\asagay\Desktop\Assays\BCA\BCASummary.xls")
Windows("BCASummary.xls").Activate
ActiveSheet.Columns(1).SpecialCells (xlCellTypeLastCell)
ActiveSheet.Paste
Selection.SpecialCells(xlCellTypeBlanks).Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Selection.SpecialCells(xlCellTypeBlanks).Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("A17").Select
ActiveWorkbook.Save
ActiveWindow.Close
Columns("A:E").Select
Range("E1").Activate
Selection.EntireColumn.Hidden = True
ActiveSheet.ShowAllData
ChDir "C:\Documents and Settings\asagay\Desktop\Assays\BCA"
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\asagay\Desktop\Assays\BCA\" & wbname,
FileFormat _
:=xlNormal, Password:="", WriteResPassword:="",
ReadOnlyRecommended:= _
False, CreateBackup:=False
Workbooks.Open ("C:\Documents and
Settings\asagay\Desktop\Assays\BCA\BCASummary.xls")
ActiveWorkbook.Save
ActiveWindow.Close
End Sub

 

[Gord Dibben]

See how Ron de Bruin does it.

All code provided.

http://www.rondebruin.nl/copy5.htm


Gord Dibben MS Excel MVP

 

[Dave Peterson]

Untested, but it did compile.

I tried to include comments so that you could change the code to what you
needed. It's sometimes difficult to determine.

Anyway...

Option Explicit
Sub Macro1()

Dim wkbkName As String
Dim wkbk As Workbook

Dim LastRow As Range

Dim rng As Range
Dim VisRng As Range

Dim SummWkbkName As String
Dim SummWkbk As Workbook

Dim NextCell As Range
Dim myPath As String

myPath = "C:\Documents and Settings\asagay\Desktop\Assays\BCA\"
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If

SummWkbkName = myPath & "BCASummary.xls"

With ActiveSheet
wkbkName = .Range("g1").Value & .Range("j1").Value
'unhide the columns
.UsedRange.Columns.Hidden = False
'remove any existing autofilter arrows
.AutoFilterMode = False

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'filter columns A:J headers in row 1
'lastrow determined by data in column A
.Range("A1:J" & LastRow).AutoFilter _
Field:=1, Criteria1:=.Range("j1").Value

Set rng = .AutoFilter.Range

If rng.Columns(1).SpecialCells(xlVisible).Count = 1 Then
MsgBox "No visible rows except the header--no copy|paste done!"
Else
'reduce the number of rows by 1 to avoid the header
'with .resize(.rows-1)
'and avoid the header with .offset(1,0)
'avoid the headers (.offset(1,0)
Set VisRng = rng.Resize(rng.Rows - 1).Offset(1, 0) _
.Cells.SpecialCells(xlCellTypeVisible)

Set SummWkbk = Workbooks.Open(Filename:=SummWkbkName)

'change the name of the sheet here!
With SummWkbk.Worksheets("Sheet1")
Set NextCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With

VisRng.Copy _
Destination:=NextCell

'I'm not sure what you're doing here
NextCell.Resize(VisRng.Columns(1).Cells.Count, _
VisRng.Rows(1).Cells.Count) _
.Cells.SpecialCells(xlCellTypeBlanks).Delete shift:=xlToLeft

SummWkbk.Close savechanges:=True

.Range("e:e").Hidden = True

.ShowAllData

'the parent of the activesheet is the activeworkbook
.Parent.SaveAs _
Filename:=myPath & wkbkName, _
FileFormat:=xlNormal, _
Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, _
CreateBackup:=False

'why open this bcasummary.xls file again?
'It was just modified and saved?
End If
End With

End Sub