RE: Making a collection of EntireRows for copying and then deletin

This should be close. It looks in Column A of *** 1 for X's and if there
are any copies them to cell A2 on *** 2. It then deletes all of the X rows
found on sheet1. You will need to change the set statements at the beginning
of this code but that should be about it...

Public Sub FindStuff()
Dim wksFrom As Work***
Dim rngToSearch As Range
Dim rngFound As Range
Dim rngFoundAll As Range
Dim rngDestination As Range
Dim strFirstAddress As String

Set rngDestination = Sheets("Sheet2").Range("A2")
Set wksFrom = Sheets("Sheet1")
Set rngToSearch = wksFrom.Range("A:A")
Set rngFound = rngToSearch.Find(What:="X", _
LookAt:=xlWhole, _
LookIn:=xlFormulas, _
MatchCase:=False)
If rngFound Is Nothing Then
MsgBox "Sorry no X's were found."
Else
Set rngFoundAll = rngFound.EntireRow
strFirstAddress = rngFound.Address
Do
Set rngFoundAll = Union(rngFound.EntireRow, rngFoundAll)
Set rngFound = rngToSearch.FindNext(After:=rngFound)
Loop Until rngFound.Address = strFirstAddress
rngFoundAll.Copy rngDestination
rngFoundAll.Delete
End If
End Sub
--
HTH...

Jim Thomlinson


"Bill Case" wrote:

Thanks JLGWhiz;

Below is the key part; The rest just does some formatting etc. in the
archive file.

Sub ArchiveMembers()

On Error GoTo ArchiveMembers_Error

' Declare variables
' Member_LName
Dim RngLength As Integer
Dim IntireRows As Variant


' Initiate variables
' "Member_Lname" is a named range that keeps track of the number of rows
' in the data base - used in several procedures.

RngLength = Range("Member_LNames").Count

Dim i As Integer
For i = 1 To RngLength
If Range("Member_LNames").Cells(i, 0) = "X" Then
IntireRows = IntireRows + Range("Member_LNames") _
.Cells(i, 0).EntireRow.Address + ", "
End If
Next i


' "$4:$4" is the label row; but really has only been added so that the
collection
' of addresses doesn't end in ", " -- selection.copy won't work without it.
For
' the user it is really not needed.

IntireRows = IntireRows + "$4:$4"
Application.CutCopyMode = False
Worksheets("Member_List").Range(IntireRows).Select
Selection.Copy

' I am only selecting because I can't make it work any other way. I would
rather
' have it working quietly in the background.
' The rest of the code finds the correct start cell in the archive file;
pastes special ' the value goes back gets a single line and pastes special
column widths and
' format for lables line. And that's as far as I have gotten.

On Error GoTo 0
Exit Sub

ArchiveMembers_Error:

MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure
ArchiveMembers of Module MembWorkAreaMod"
End Sub

This is a volunteer project for a club I am a member of. I am not a
professional programmer.

"JLGWhiz" wrote:

Let us see what you have.

"Bill Case" wrote:

Hi All;

I think I am doing things the hard way. It is taking me about 50 lines and
looks awfully hacky. All suggestions gratefully received.

I have a small data base (30-40 members of a local club). I want the user
to be able to flag with an 'X' expired memberships in one column of the data
row. I want a procedure to do the following:

Loop through the range of members;
Pick out the 'X' members;
Save the address of the EntireRow of the membership info as a collection of
IntireRow addresses;
Then using the list/collection of Xed rows
Copy the IntireRow data and paste special (values) to an archive file;
Then delete the marked 'X' membership IntireRows;

I have something that kinda works, but it is long, messy and has to be
easier, neater.

Just some suggested key objects, methods and/or commands would be helpful.

Regards Bill
.

Loading