Transfering records based on a condition
 

I have a list of records. I want to move all of the records (cols B thru E)
to sheet "Verified "if the value in the A col is a "X" . The Records will be
added to the bottom of the existing list in Sheet "Verified"

oldjay

Transfering records based on a condition
 

Hi OldJay,

Try something like:

'============
Public Sub CopyRange()
Dim WB As Workbook
Dim SH As Worksheet
Dim destSH As Worksheet
Dim destRng As Range
Dim rng As Range
Dim copyRng As Range
Dim rCell As Range
Dim LRow As Long
Dim CalcMode As Long
Const sStr = "X"

Set WB = Workbooks("MyBook.xls") '<<==== CHANGE

With WB
Set SH = .Sheets("Sheet1")
Set destSH = .Sheets("Verified")
End With

Set destRng = destSH.Cells(Rows.Count, "A").End(xlUp)(2)
LRow = Cells(Rows.Count, "A").End(xlUp).Row
Set rng = SH.Range("A1:A" & LRow)

On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

For Each rCell In rng.Cells
If InStr(1, rCell, sStr, vbTextCompare) 0 Then
If copyRng Is Nothing Then
Set copyRng = rCell.Offset(0, 1).Resize(1, 4)
Else
Set copyRng = _
Union(rCell.Offset(0, 1).Resize(1, 4), copyRng)
End If
End If
Next rCell

If Not copyRng Is Nothing Then
copyRng.Copy Destination:=destRng
End If

XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub
'<<============

---
Regards,
Norman



"Oldjay" wrote in message
...
I have a list of records. I want to move all of the records (cols B thru E)
to sheet "Verified "if the value in the A col is a "X" . The Records will
be
added to the bottom of the existing list in Sheet "Verified"

oldjay

Transfering records based on a condition
 

"Norman Jones" wrote:

Hi OldJay,

Try something like:

'============
Public Sub CopyRange()
Dim WB As Workbook
Dim SH As Worksheet
Dim destSH As Worksheet
Dim destRng As Range
Dim rng As Range
Dim copyRng As Range
Dim rCell As Range
Dim LRow As Long
Dim CalcMode As Long
Const sStr = "X"

Set WB = Workbooks("MyBook.xls") '<<==== CHANGE

With WB
Set SH = .Sheets("Sheet1")
Set destSH = .Sheets("Verified")
End With

Set destRng = destSH.Cells(Rows.Count, "A").End(xlUp)(2)
LRow = Cells(Rows.Count, "A").End(xlUp).Row
Set rng = SH.Range("A1:A" & LRow)

On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

For Each rCell In rng.Cells
If InStr(1, rCell, sStr, vbTextCompare) 0 Then
If copyRng Is Nothing Then
Set copyRng = rCell.Offset(0, 1).Resize(1, 4)
Else
Set copyRng = _
Union(rCell.Offset(0, 1).Resize(1, 4), copyRng)
End If
End If
Next rCell

If Not copyRng Is Nothing Then
copyRng.Copy Destination:=destRng
End If

XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub
'<<============

---
Regards,
Norman



"Oldjay" wrote in message
...
I have a list of records. I want to move all of the records (cols B thru E)
to sheet "Verified "if the value in the A col is a "X" . The Records will
be
added to the bottom of the existing list in Sheet "Verified"

oldjay

Transfering records based on a condition
 

I didn't tell you every thing
The list in Sheet 1 starts at row B20
The list on sheet Verify starts B9
I want to move them not copy to the bottom of the existing list

"Oldjay" wrote:



"Norman Jones" wrote:

Hi OldJay,

Try something like:

'============
Public Sub CopyRange()
Dim WB As Workbook
Dim SH As Worksheet
Dim destSH As Worksheet
Dim destRng As Range
Dim rng As Range
Dim copyRng As Range
Dim rCell As Range
Dim LRow As Long
Dim CalcMode As Long
Const sStr = "X"

Set WB = Workbooks("MyBook.xls") '<<==== CHANGE

With WB
Set SH = .Sheets("Sheet1")
Set destSH = .Sheets("Verified")
End With

Set destRng = destSH.Cells(Rows.Count, "A").End(xlUp)(2)
LRow = Cells(Rows.Count, "A").End(xlUp).Row
Set rng = SH.Range("A1:A" & LRow)

On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

For Each rCell In rng.Cells
If InStr(1, rCell, sStr, vbTextCompare) 0 Then
If copyRng Is Nothing Then
Set copyRng = rCell.Offset(0, 1).Resize(1, 4)
Else
Set copyRng = _
Union(rCell.Offset(0, 1).Resize(1, 4), copyRng)
End If
End If
Next rCell

If Not copyRng Is Nothing Then
copyRng.Copy Destination:=destRng
End If

XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub
'<<============

---
Regards,
Norman



"Oldjay" wrote in message
...
I have a list of records. I want to move all of the records (cols B thru E)
to sheet "Verified "if the value in the A col is a "X" . The Records will
be
added to the bottom of the existing list in Sheet "Verified"

oldjay

Transfering records based on a condition
 

Hi OldJay,

'--------------------
I didn't tell you every thing
The list in Sheet 1 starts at row B20
The list on sheet Verify starts B9
I want to move them not copy to the bottom of the existing list
'--------------------

Try the following version:

'============
Public Sub CopyRange()
Dim WB As Workbook
Dim SH As Worksheet
Dim destSH As Worksheet
Dim destRng As Range
Dim rng As Range
Dim copyRng As Range
Dim rCell As Range
Dim LRow As Long
Dim iRow As Long
Dim CalcMode As Long
Const sStr = "X"

Set WB = Workbooks("MyBook.xls") '<<==== CHANGE

With WB
Set SH = .Sheets("Sheet1")
Set destSH = .Sheets("Verified")
End With

With destSH
iRow = .Range("B" & .Rows.Count).End(xlUp).Row
If iRow < 9 Then
iRow = 8
End If

Set destRng = .Range("B" & iRow + 1)
End With

With SH
LRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A1:A" & LRow)
End With

On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

For Each rCell In rng.Cells
If InStr(1, rCell, sStr, vbTextCompare) 0 Then
If copyRng Is Nothing Then
Set copyRng = rCell.Offset(0, 1).Resize(1, 4)
Else
Set copyRng = _
Union(rCell.Offset(0, 1).Resize(1, 4), copyRng)
End If
End If
Next rCell

If Not copyRng Is Nothing Then
With copyRng
.Copy Destination:=destRng
.EntireRow.Delete
End With
End If

XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub
'<<============


---
Regards,
Norman

Transfering records based on a condition
 

Hi OldJay,

Please change:

Set rng = .Range("A1:A" & LRow)

with

Set rng = .Range("A20:A" & LRow)


---
Regards,
Norman

Transfering records based on a condition
 

Code is Removing Records with "X" but is not inserting then into destSheet

"Norman Jones" wrote:

Hi OldJay,

Please change:

Set rng = .Range("A1:A" & LRow)

with

Set rng = .Range("A20:A" & LRow)


---
Regards,
Norman

Transfering records based on a condition
 

Hi OldJay,

The code works for me without problem: it copies
columns B:E of all rows on Sheet1, from row 20
onward, which have a column a value of X, to the
foot of a list in the sheet 'Verified' which starts at
cell B9.

---
Regards,
Norman
Microsoft Excel MVP


"Oldjay" wrote in message
...
Code is Removing Records with "X" but is not inserting then into destSheet

"Norman Jones" wrote:

Hi OldJay,

Please change:

Set rng = .Range("A1:A" & LRow)

with

Set rng = .Range("A20:A" & LRow)


---
Regards,
Norman

Transfering records based on a condition
 

I think my problem is that the B col is sometimes blank
The C col alway has an entry
oldjay

"Norman Jones" wrote:

Hi OldJay,

The code works for me without problem: it copies
columns B:E of all rows on Sheet1, from row 20
onward, which have a column a value of X, to the
foot of a list in the sheet 'Verified' which starts at
cell B9.

---
Regards,
Norman
Microsoft Excel MVP


"Oldjay" wrote in message
...
Code is Removing Records with "X" but is not inserting then into destSheet

"Norman Jones" wrote:

Hi OldJay,

Please change:

Set rng = .Range("A1:A" & LRow)

with

Set rng = .Range("A20:A" & LRow)


---
Regards,
Norman

Transfering records based on a condition
 

Hi OldJay,

Perhaps you would care to send me a sample of
problematic data.

norman_jones@NOSPAMbtconnectDOTcom

(Delete "NOSPAM" and replace "DOT" with a full stop [period] )



---
Regards,
Norman



"Oldjay" wrote in message
...
I think my problem is that the B col is sometimes blank
The C col alway has an entry
oldjay

"Norman Jones" wrote:

Hi OldJay,

The code works for me without problem: it copies
columns B:E of all rows on Sheet1, from row 20
onward, which have a column a value of X, to the
foot of a list in the sheet 'Verified' which starts at
cell B9.

---
Regards,
Norman
Microsoft Excel MVP


"Oldjay" wrote in message
...
Code is Removing Records with "X" but is not inserting then into
destSheet

"Norman Jones" wrote:

Hi OldJay,

Please change:

Set rng = .Range("A1:A" & LRow)

with

Set rng = .Range("A20:A" & LRow)


---
Regards,
Norman

Transfering records based on a condition
 

I tried to send you the whole work book but it failed (Security?) with the
following message

Norman - I have enclosed a copy of my file. Please note that I have not
assigned any code to the Command buttons yet.
I changed Cols B and C so that there was always data in the B col just in
case thats was the problem. I also changed the sheet names to Checkbook and
Checkbook Summary.

Public Sub CopyRange()
Dim WB As Workbook
Dim SH As Worksheet
Dim destSH As Worksheet
Dim destRng As Range
Dim rng As Range
Dim copyRng As Range
Dim rCell As Range
Dim LRow As Long
Dim iRow As Long
Dim CalcMode As Long
Const sStr = "X"

Set WB = Workbooks("Bank Balance Worksheet .xls")

With WB
Set SH = .Sheets("Checkbook")
Set destSH = .Sheets("Checkbook Summary")
End With

With destSH
iRow = .Range("B" & .Rows.Count).End(xlUp).Row
If iRow < 9 Then
iRow = 8
End If

Set destRng = .Range("B" & iRow + 1)
End With

With SH
LRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A20:A" & LRow)
End With

On Error GoTo XIT
With Application
CalcMode = .Calculation
..Calculation = xlCalculationManual
..ScreenUpdating = False
End With

For Each rCell In rng.Cells
If InStr(1, rCell, sStr, vbTextCompare) 0 Then
If copyRng Is Nothing Then
Set copyRng = rCell.Offset(0, 1).Resize(1, 4)
Else
Set copyRng = _
Union(rCell.Offset(0, 1).Resize(1, 4), copyRng)
End If
End If
Next rCell

If Not copyRng Is Nothing Then
With copyRng
..Copy Destination:=destRng
..EntireRow.Delete
End With
End If

XIT:
With Application
..Calculation = CalcMode
..ScreenUpdating = True
End With
End Sub


"Norman Jones" wrote:

Hi OldJay,

Perhaps you would care to send me a sample of
problematic data.

norman_jones@NOSPAMbtconnectDOTcom

(Delete "NOSPAM" and replace "DOT" with a full stop [period] )



---
Regards,
Norman



"Oldjay" wrote in message
...
I think my problem is that the B col is sometimes blank
The C col alway has an entry
oldjay

"Norman Jones" wrote:

Hi OldJay,

The code works for me without problem: it copies
columns B:E of all rows on Sheet1, from row 20
onward, which have a column a value of X, to the
foot of a list in the sheet 'Verified' which starts at
cell B9.

---
Regards,
Norman
Microsoft Excel MVP


"Oldjay" wrote in message
...
Code is Removing Records with "X" but is not inserting then into
destSheet

"Norman Jones" wrote:

Hi OldJay,

Please change:

Set rng = .Range("A1:A" & LRow)

with

Set rng = .Range("A20:A" & LRow)


---
Regards,
Norman

Transfering records based on a condition
 

Hi OldJay,

I tried to send you the whole work book but it failed (Security?)

There should be no problem.

On the assumption that your email address has not changed
in the last year, I have sent you an email in order to provide
you with a return address.


---
Regards,
Norman

Transfering records based on a condition
 

Did you get my email with the program with the troublesome Code?
oldjay

"Norman Jones" wrote:

Hi OldJay,

I tried to send you the whole work book but it failed (Security?)

There should be no problem.

On the assumption that your email address has not changed
in the last year, I have sent you an email in order to provide
you with a return address.


---
Regards,
Norman

Transfering records based on a condition
 

My problem was the fact that there was some entries in row 5000 and the the
new rows were being copied below these entries As soon as I deleted these
entries everything worked great!
Thanks
oldjay

"Norman Jones" wrote:

Hi OldJay,

I tried to send you the whole work book but it failed (Security?)

There should be no problem.

On the assumption that your email address has not changed
in the last year, I have sent you an email in order to provide
you with a return address.


---
Regards,
Norman