Copying a range to different worksheets/workbooks

[john.bedford3]

I have a spreadsheet which contains a list as follows Sorted by Col A then
G.

A G H I J
Abbot 27-Oct-2003 London 24 13
Abbot 20-Feb-2002 Norwich 22 08
Abbot 29-Apr-2001 Hull 20 02
Abbot 04-Jun-2000 Grantham 19 12
Brown 20-May-2004 Newark 35 14
Brown 06-Jul-2002 Sheffield 35 06
Brown 23-Mar-2002 London 33 12
Brown 18-Sep-1960 Woodford 33 10
Davis 16-Jun-2004 Chigwell 29 02
Davis 23-Dec-2003 Loughton 26 11
Davis 05-May-2002 Glasgow 25 04
Davis 14-Aug-2001 Cardiff 23 01
Davis 28-Jul-2001 Debden 23 00
Davis 02-Feb-2000 Woodford 19 01

The list changes regularly and I need to copy data from this list to
spreadsheets in different workbooks based on certain criteria.

For example.

Where Col A = Brown. And Col G is less than 01-Jan-2004. I wish to copy to
Cols B,C,D,E and F in row 3,4 & 5 respectively in another workbook the first
3 rows in this list where these criteria are matched. Where there is less
that 3 rows that match the criteria copy only the available matches.

For each workbook I copy to the criteria for Col A and Col G will be
different so I need a formula that I can adapt to place in each worksheet to
extract the information.

Any help you can give would be greatfully appreciated

 

[Bob Phillips]

John,

Here is a macro. You would pass the name and the date to the macro like so

MoveData "Brown", Dateserial(2004,1,1)

Sub MoveData(name As String, limit As Date)
Dim clastrow As Long
Dim cMatch As Long
Dim rng As Range
Dim i As Long

clastrow = Cells(Rows.Count, "A").End(xlUp).Row
cMatch = 0
Workbooks.Add
With ThisWorkbook.ActiveSheet
For i = 1 To clastrow
If .Cells(i, "A").Value = name Then
If .Cells(i, "B").Value < limit Then
If rng Is Nothing Then
Set rng = .Cells(i, "B").Resize(1, 5)
Else
Set rng = Union(rng, .Cells(i, "B").Resize(1, 5))
End If
cMatch = cMatch + 1
If cMatch = 3 Then Exit For
End If
End If
Next i
End With

If rng Is Nothing Then

MsgBox "No matches found"
ActiveWorkbook.Close savechanges:=False
Else
rng.Copy Destination:=ActiveWorkbook.Worksheets(1).Range("A1")
ActiveWorkbook.SaveAs Filename:=Format(limit, "yyyy-mm-dd") & " " &
name & ".xls"
End If

End Sub

--

HTH

RP
(remove nothere from the email address if mailing direct)

 

[Max]

You would pass the name and the date to the macro like so
MoveData "Brown", Dateserial(2004,1,1)
Sub MoveData(name As String, limit As Date)

.....
Tried hard to follow your steps here for Sub MoveData,
but failing miserably, Bob. Couldn't step thru' Sub MoveData
pasted as-is with F8 in VBE. Nothing happens.
Probably I'm missing some crucial implementation steps.
Perhaps you could throw some extra explanation here?
Thanks.

 

[Bob Phillips]

Hi Max,

You won't be able to step thru that sub directly, as it has arguments, and
if you try stepping through directly, the arguments are empty.

Try adding this small sub, and step through from there, and then into
MoveData.

Sub TestMoveData()
MoveData "Brown", Dateserial(2004,1,1)
End Sub

I added the arguments to give the OP the repeatability/flexibility he
sought.

Regards

Bob

 

[Max]

Aha, now you're talking my language <g> Thanks, Bob !
One other question, according to the orig. post, the dates are in col G.
Is there any part in your Sub which needs to be adapted to suit, and if so,
which / how? Thanks

 

[Bob Phillips]

<blush>. You are right, I just saw it as the second column. So to adapt for
that you need to change these lines

For i = 1 To clastrow
If .Cells(i, "A").Value = name Then
If .Cells(i, "B").Value < limit Then
If rng Is Nothing Then
Set rng = .Cells(i, "B").Resize(1, 5)
Else
Set rng = Union(rng, .Cells(i, "B").Resize(1, 5))

to

For i = 1 To clastrow
If .Cells(i, "A").Value = name Then
If .Cells(i, "G").Value < limit Then
If rng Is Nothing Then
Set rng = .Cells(i, "B").Resize(1, 5)
Else
Set rng = Union(rng, .Cells(i, "B").Resize(1, 5))


I think that is all it needs. The resize doesn't need to change because the
OP wants to copy columns B,C,D,E and F.

--

HTH

RP
(remove nothere from the email address if mailing direct)

 

[Max]

Many thanks, Bob !
Runs *Great* ..