copy to new workbook

[hakuna12]

Sub copysheet()

Dim lastLine As Long
Dim findWhat As String
Dim toCopy As Boolean
Dim cell As Range
Dim i As Long
Dim j As Long
Dim newbook As Workbook

'Application.ScreenUpdating = False
findWhat = CStr(InputBox("Enter the AREA name to search for: "))
lastLine = ActiveSheet.UsedRange.Rows.Count

j = 1
For i = 1 To lastLine
For Each cell In Range("E1:F1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
'Rows(i).Copy Destination:=Workbooks.Add.Sheets(1).Rows(j)
Rows(i).Copy Destination:=Sheets("new").Rows(j)
j = j + 1
Application.CutCopyMode = False
End If
toCopy = False
Next

i = MsgBox(((j - 1) & " row(s) were copied!"), vbOKOnly, "Result")

'Application.ScreenUpdating = True

End Sub


Hello friends, the code i have is able to copy into a new sheet of the same workbook. But i want to make modifications so that i can copy the sheet into a new workbook directly.

hope you will help me with this.

thanks!

 

[IRstuff]

Macro Recorder when I copied a cell from one workbook to another:



Range("A2").Select
Selection.Copy
Windows("Book2").Activate
Range("B3").Select
ActiveSheet.Paste


TTFN
faq731-376

 

[MintJulep]

No need to, and inefficient to use the clipboard. Just do This = That.

Public Sub Duplicate()
Dim c As Range
Dim Source As Range
Set Source = Workbooks("Book1").Worksheets("Sheet1").UsedRange
For Each c In Source
Workbooks("Book2").Worksheets("Sheet1").Cells(c.Row, c.Column) = c.Value
Next c
End Sub

 

[MintJulep]

A little more robust - so that formulae survive

Public Sub Duplicate()
Dim c As Range
Dim Source As Range
Set Source = Workbooks("Book1").Worksheets("Sheet1").UsedRange
For Each c In Source
If c.Formula = nul Then
Workbooks("Book2").Worksheets("Sheet1").Cells(c.Row, c.Column).Value = c.Value
Else
Workbooks("Book2").Worksheets("Sheet1").Cells(c.Row, c.Column).Formula = c.Formula
End If
Next c
End Sub

 

[Hoaokapohaku]

I ran out of time to work on this, but I think this should work as is

Sub copysheet()

Dim lastLine As Long
Dim findWhat As String
Dim toCopy As Boolean
Dim cell As Range
Dim i As Long
Dim j As Long
'Dim newbook As Workbook
Dim NewWBName As String
Dim NewWB As Workbook
Dim ThisWB As Workbook

'Application.ScreenUpdating = False
Set ThisWB = ActiveWorkbook
findWhat = CStr(InputBox("Enter the AREA name to search for: "))
lastLine = ActiveSheet.UsedRange.Rows.Count
'EDIT PATH AND FILE NAME BELOW
NewWBName = "C:\Users\User\Documents\Test.xlsm"
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=NewWBName, _
    FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Set NewWB = ActiveWorkbook
ThisWB.Activate
j = 1
For i = 0 To lastLine
    For Each cell In Range("E1:F1").Offset(i, 0)
        If InStr(cell.Text, findWhat) <> 0 Then
                toCopy = True
        End If
    Next
    If toCopy = True Then
        ThisWB.Sheets("sheet3").Rows(i + 1).Copy _
            Destination:=NewWB.Sheets("Sheet1").Range("A1").Offset(j, 0)
    j = j + 1
    End If
    toCopy = False
Next
i = MsgBox(((j - 1) & " row(s) were copied!"), vbOKOnly, "Result")
'Application.ScreenUpdating = True
End Sub