macro to copy into different worksheets

[Guest]

I have a excel worksheet which shows a list like below.

Directory of C:\Sarah\files\Dec04

09/02/2005 13:30 6,312 Dec04.sav
1 File(s) 6,312 bytes

Directory of C:\Sarah\code\Admissions\0001

20/04/2004 14:45 290,929,896 adm0001.sav
1 File(s) 290,929,896 bytes


What I want a macro to do is to look down this worksheet and select each
record on the list. I.E find the line starting with the word Directory,
selecting all the lines below until it gets to another line starting with
Directory, it then pastes this into a different worksheet. then goes back and
selects the next record etc. The distance between the rows containing
"Directory" can vary in length.
I am not very experienced in Visual Basic and I can not get it to select the
range of rows I need.

 

[Dave Peterson]

How about this?

Option Explicit
Sub testme()
Dim newWks As Worksheet
Dim curWks As Worksheet
Dim TopCell As Range
Dim BotCell As Range
Dim FoundCell As Range
Dim FirstAddress As String
Dim myRng As Range

Set curWks = Worksheets("sheet1")
Set myRng = curWks.Range("a:a")

With curWks
With myRng
Set FoundCell = .Find(what:="directory", _
after:=.Cells(.Cells.Count), _
lookat:=xlPart, LookIn:=xlValues, _
searchdirection:=xlNext)
End With

If FoundCell Is Nothing Then
MsgBox "None found!"
Exit Sub
End If

FirstAddress = FoundCell.Address
.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Value _
= "Directory Dummy"

Set TopCell = FoundCell

Do
Set FoundCell = myRng.FindNext(FoundCell)

If FoundCell.Address = FirstAddress Then
Exit Do
End If

Set BotCell = FoundCell
Set newWks = Worksheets.Add
.Range(TopCell, BotCell.Offset(-1, 0)).EntireRow.Copy _
Destination:=newWks.Range("a1")

Set TopCell = BotCell

Loop

.Cells(.Rows.Count, "A").End(xlUp).EntireRow.Delete

End With

End Sub

 

[Guest]

Thank you very much, that worked perfectly.

How about this?

Option Explicit
Sub testme()
Dim newWks As Worksheet
Dim curWks As Worksheet
Dim TopCell As Range
Dim BotCell As Range
Dim FoundCell As Range
Dim FirstAddress As String
Dim myRng As Range

Set curWks = Worksheets("sheet1")
Set myRng = curWks.Range("a:a")

With curWks
With myRng
Set FoundCell = .Find(what:="directory", _
after:=.Cells(.Cells.Count), _
lookat:=xlPart, LookIn:=xlValues, _
searchdirection:=xlNext)
End With

If FoundCell Is Nothing Then
MsgBox "None found!"
Exit Sub
End If

FirstAddress = FoundCell.Address
.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Value _
= "Directory Dummy"

Set TopCell = FoundCell

Do
Set FoundCell = myRng.FindNext(FoundCell)

If FoundCell.Address = FirstAddress Then
Exit Do
End If

Set BotCell = FoundCell
Set newWks = Worksheets.Add
.Range(TopCell, BotCell.Offset(-1, 0)).EntireRow.Copy _
Destination:=newWks.Range("a1")

Set TopCell = BotCell

Loop

.Cells(.Rows.Count, "A").End(xlUp).EntireRow.Delete

End With

End Sub