VB Macro Help

[AA388]

Any Excel bods around? .

I want to copy a row of data from sheet 1 and copy it into another sheet in the same workbook. With this I can select which row I want and copy it into a new sheet which is created with a new name. The problem I have with it is that it also copies row 1 which I don't want, just the one I select. Any ideas?

Sub Macro7()
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

'Set filter range on ActiveSheet: A1 is the top left cell of your filter range
'and the header of the first column, D is the last column in the filter range.
'You can also add the sheet name to the code like this :
'Worksheets("Sheet1").Range("A1:M" & LastRow(Worksheets("Sheet1")))
'No need that the sheet is active then when you run the macro when you use this.
Set My_Range = Range("A1:Z" & LastRow(ActiveSheet))
My_Range.Parent.Select

If ActiveWorkbook.ProtectStructure = True Or _
My_Range.Parent.ProtectContents = True Then
MsgBox "Sorry, not working when the workbook or worksheet is protected", _
vbOKOnly, "Copy to new worksheet"
Exit Sub
End If

'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 the filter criteria :
'This example filter on the first column in the range (change the field if needed)
'In this case the range starts in A so Field 1 is column A, 2 = column B, ......
'Use "<>Netherlands" as criteria if you want the opposite
'My_Range.AutoFilter Field:=1, Criteria1:="="

'If you want to filter on a cell value you can use this, use "<>" for the opposite
'This example uses the activecell value
'My_Range.AutoFilter Field:=1, Criteria1:="=" & ActiveCell.Value

'This will use the cell value from A2 as criteria
'My_Range.AutoFilter Field:=1, Criteria1:="=" & Range("A2").Value

''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:=1, 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
'Add a new Worksheet
Set WSNew = Worksheets.Add(After:=Sheets(ActiveSheet.Index))

'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
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 xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With

' If you want to delete the rows that you copy, also use this
' With My_Range.Parent.AutoFilter.Range
' On Error Resume Next
' Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
' .SpecialCells(xlCellTypeVisible)
' On Error GoTo 0
' If Not rng Is Nothing Then rng.EntireRow.Delete
' End With

End If

'Close AutoFilter
My_Range.Parent.AutoFilterMode = False

'Restore ScreenUpdating, Calculation, EnableEvents, ....
My_Range.Parent.Select
ActiveWindow.View = ViewMode
If Not WSNew Is Nothing Then WSNew.Select
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("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function



Thanks
John

 

[repomanbe]

I'll have a quick butchers, but initial look shows it will not copy the 'row' you want but all rows that meet the filter criteria. It looks like you are not searching for the row(s) you want to copy but filtering out all the rows you don't + a header row and then copy everything left into a new worksheet

if as your text suggests only one row is going to be copied you don't need such a long complex script.

but, is it likely more than one row is to be copied?

 

[repomanbe]

had a look,

firstly remove the top line
Sub Macro7()

there's no macro and corresponding End Sub

After the comment - ' Copy/paste the visible data to the new worksheet
Remove or filter out this line - My_Range.Parent.AutoFilter.Range.Copy

before the comment line 'Add a new Worksheet
insert these two lines
'Set up copy range to exclude Header Row
Range("A2:Z" & LastRow(ActiveSheet)).Copy

so it should read
_____________________________________________________________

'Set up copy range to exclude Header Row
Range("A2:Z" & LastRow(ActiveSheet)).Copy

'Add a new Worksheet
Set WSNew = Worksheets.Add(After:=Sheets(ActiveSheet.Index))

'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
'My_Range.Parent.AutoFilter.Range.Copy
With WSNew.Range("A1")

_____________________________________________________________


think it should work, have play and see

Mike

 

[AA388]

Thanks Mike!