copy to new workbook
copy to new workbook
(OP)
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!
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!





RE: copy to new workbook
Range("A2").Select
Selection.Copy
Windows("Book2").Activate
Range("B3").Select
ActiveSheet.Paste
TTFN
FAQ731-376: Eng-Tips.com Forum Policies
RE: copy to new workbook
CODE
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 SubRE: copy to new workbook
CODE -->
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 SubRE: copy to new workbook
CODE -->
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