Capture
 

Every time Column I has €œ04€� or €œ05€� in a row, I would like to cut that
entire row Columns A:AH, create a new worksheet named €œ0405€� , and paste
those cut rows into the new worksheet, so that the rows do not overlap.

Here is what I have so far. Any help would be appreciated.

Sub Capture0405()

Set newsht = Sheets.Add(after:=Sheets(Sheets.Count))
newsht.Name = "0405"
End Sub

Capture
 

Sub Capture0405()

set oldsht = activesheet
Set newsht = Sheets.Add(after:=Sheets(Sheets.Count))
newsht.Name = "0405"

NewRow = 1
with oldsht
OldRow = 1
do while .Range("I" & OldRow) < ""
if .Range("I" & OldRow) = 4 or _
.Range("I" & OldRow) = 5 then
.Range("A" & OldRow & ":H" & OldRow).copy _
Destination:=NewSht.Range("A" & Newrow)
NewRow = NewRow + 1
end if
OldRow = OldRow + 1
Loop
End Sub


"Sal" wrote:

Every time Column I has €œ04€� or €œ05€� in a row, I would like to cut that
entire row Columns A:AH, create a new worksheet named €œ0405€� , and paste
those cut rows into the new worksheet, so that the rows do not overlap.

Here is what I have so far. Any help would be appreciated.

Sub Capture0405()

Set newsht = Sheets.Add(after:=Sheets(Sheets.Count))
newsht.Name = "0405"
End Sub

Capture
 

Try code like the following. It will create the sheet "0405" if it
doesn't exist.

Sub AAA()

Dim LastRow As Long
Dim RowNdx As Long
Dim SourceWS As Worksheet
Dim DestWS As Worksheet
Dim Dest As Range
Dim DeleteThese As Range
Dim R As Range

Set SourceWS = Worksheets("Sheet1") '<<< Change
On Error Resume Next
Set DestWS = Worksheets("0405")
If DestWS Is Nothing Then
' doesn't exist. create it.
With ThisWorkbook.Worksheets
Set DestWS = .Add(after:=.Item(.Count))
DestWS.Name = "0405"
End With
End If
With DestWS
Set Dest = .Cells(.Rows.Count, "A").End(xlUp)
If Dest.Value < vbNullString Then
Set Dest = Dest(2, 1)
End If
End With
On Error GoTo 0
With SourceWS
LastRow = .Cells(.Rows.Count, "I").End(xlUp).Row
For RowNdx = 1 To LastRow
Set R = .Cells(RowNdx, "i")
Select Case R.Value
Case "04", "05"
If DeleteThese Is Nothing Then
Set DeleteThese = R.EntireRow
Else
Set DeleteThese = _
Application.Union(DeleteThese, R.EntireRow)
End If
R.EntireRow.Copy Destination:=Dest
Set Dest = Dest(2, 1)
Case Else
' do nothing
End Select
Next RowNdx
End With

If Not DeleteThese Is Nothing Then
DeleteThese.Delete
End If

End Sub


Cordially,
Chip Pearson
Microsoft Most Valuable Professional
Excel Product Group, 1998 - 2009
Pearson Software Consulting, LLC
www.cpearson.com
(email on web site)



On Thu, 28 May 2009 13:31:01 -0700, Sal
wrote:

Every time Column I has “04” or “05” in a row, I would like to cut that
entire row Columns A:AH, create a new worksheet named “0405” , and paste
those cut rows into the new worksheet, so that the rows do not overlap.

Here is what I have so far. Any help would be appreciated.

Sub Capture0405()

Set newsht = Sheets.Add(after:=Sheets(Sheets.Count))
newsht.Name = "0405"
End Sub

Capture
 

This is great. Thank you for the help.

"Joel" wrote:


Sub Capture0405()

set oldsht = activesheet
Set newsht = Sheets.Add(after:=Sheets(Sheets.Count))
newsht.Name = "0405"

NewRow = 1
with oldsht
OldRow = 1
do while .Range("I" & OldRow) < ""
if .Range("I" & OldRow) = 4 or _
.Range("I" & OldRow) = 5 then
.Range("A" & OldRow & ":H" & OldRow).copy _
Destination:=NewSht.Range("A" & Newrow)
NewRow = NewRow + 1
end if
OldRow = OldRow + 1
Loop
End Sub


"Sal" wrote:

Every time Column I has €œ04€� or €œ05€� in a row, I would like to cut that
entire row Columns A:AH, create a new worksheet named €œ0405€� , and paste
those cut rows into the new worksheet, so that the rows do not overlap.

Here is what I have so far. Any help would be appreciated.

Sub Capture0405()

Set newsht = Sheets.Add(after:=Sheets(Sheets.Count))
newsht.Name = "0405"
End Sub

Capture
 

Wow, I appreciate this very much. The macro works very well. Thank you for
the help.

"Chip Pearson" wrote:


Try code like the following. It will create the sheet "0405" if it
doesn't exist.

Sub AAA()

Dim LastRow As Long
Dim RowNdx As Long
Dim SourceWS As Worksheet
Dim DestWS As Worksheet
Dim Dest As Range
Dim DeleteThese As Range
Dim R As Range

Set SourceWS = Worksheets("Sheet1") '<<< Change
On Error Resume Next
Set DestWS = Worksheets("0405")
If DestWS Is Nothing Then
' doesn't exist. create it.
With ThisWorkbook.Worksheets
Set DestWS = .Add(after:=.Item(.Count))
DestWS.Name = "0405"
End With
End If
With DestWS
Set Dest = .Cells(.Rows.Count, "A").End(xlUp)
If Dest.Value < vbNullString Then
Set Dest = Dest(2, 1)
End If
End With
On Error GoTo 0
With SourceWS
LastRow = .Cells(.Rows.Count, "I").End(xlUp).Row
For RowNdx = 1 To LastRow
Set R = .Cells(RowNdx, "i")
Select Case R.Value
Case "04", "05"
If DeleteThese Is Nothing Then
Set DeleteThese = R.EntireRow
Else
Set DeleteThese = _
Application.Union(DeleteThese, R.EntireRow)
End If
R.EntireRow.Copy Destination:=Dest
Set Dest = Dest(2, 1)
Case Else
' do nothing
End Select
Next RowNdx
End With

If Not DeleteThese Is Nothing Then
DeleteThese.Delete
End If

End Sub


Cordially,
Chip Pearson
Microsoft Most Valuable Professional
Excel Product Group, 1998 - 2009
Pearson Software Consulting, LLC
www.cpearson.com
(email on web site)



On Thu, 28 May 2009 13:31:01 -0700, Sal
wrote:

Every time Column I has €œ04€� or €œ05€� in a row, I would like to cut that
entire row Columns A:AH, create a new worksheet named €œ0405€� , and paste
those cut rows into the new worksheet, so that the rows do not overlap.

Here is what I have so far. Any help would be appreciated.

Sub Capture0405()

Set newsht = Sheets.Add(after:=Sheets(Sheets.Count))
newsht.Name = "0405"
End Sub