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!