Transfering records based on a condition

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

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
 
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
'<<============
 
Norman Jones said:
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
'<<============
Click to expand...
 
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
 
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
'<<============
 
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.
 
I think my problem is that the B col is sometimes blank
The C col alway has an entry
oldjay
 
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 said:
I think my problem is that the B col is sometimes blank
The C col alway has an entry
oldjay
Click to expand...
 
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 said:
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 said:
I think my problem is that the B col is sometimes blank
The C col alway has an entry
oldjay
Click to expand...
Click to expand...
 
Hi OldJay,

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.
 
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
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Deleting cells 5
Filtering with criteria in an remote cell 12
Compare data set 1 with data set 2. Add to data set 2 if not found 0
conditionally format based on intersheet cell comparisons 1
checking for a blank field 19
Add a new row in Named Table (Table1) and add data from txtboxes into last empty cells based on header named of the Table1 0
Select / Copy / Paste 6
Need to flag the lead ID of any contiguous ID's from a sorted list of ID's. 5

Back
Top