Macro Help

[Ken]

(We put this out to the "Worksheet Functions" group
yesterday and have had no response. Either we explained it
too poorly to get a response; it is too much programming
assistance to ask from this source; or the folks in that
group did not have the macro expertise to respond. So, we
are trying for assistance here.)

Using Excel 2000.

We have 2,000 - 3,000 rows of imported text data.

Sample layout is:
A B C D

1 ABC
2 xx xx $45
3 xx xx $34
4 xx $4
5 FGE
6 xx xx $55
7 xx $67
......

Rows are sorted based on the entries in Column A if there
is a blank entry in column B. There are about ten
groupings of sorted items - ten groups
labeled "ABC", "FGE", etc.
Each new group starts with a blank entry in column B.
We are trying to get a macro that will loop through the
3,000 rows; copy the range of rows from one group
(e.g. for group "ABC" we would copy rows one through
four); insert a new worksheet; paste the copied
rows to the new worksheet; rename the new worksheet with
the label from column A (e.g. "ABC"); insert a new row 1
into the new worksheet with A1="Name", A2="ID", A3="Amt";
and then loop back.
Then the macro will have to stop when it realizes it is at
the end of the data. (Alternatively, the macro could start
at the bottom and work back to the top.)
TIA.

 

[windsurferLA]

I have found this newsgroup to be exceedingly helpful with many not-so
easy questions. It is almost as if readers race to see who can be the
first to answer my questions. I think you too will get a speedy
response if you ask appropriate question(s).

I don't mean to be critical, but I speculate that you have not received
a response to your posting because you are not really asking a question.
The "answer" you are seeking is a not really an "answer," but a
solution to your problem. If you want someone to put together a
turn-key solution to your problem, I suggest you hire one of the many
Excel experts that monitor this newsgroup.

This newsgroup will undoubtedly help you develop a solution to your
problem if you partition it into smaller problems that can be asked as
questions. I suggest you block out your problem in a flow chart (or
equivalent), define the functional blocks, and then seek help on how to
implement those functions.

- - - - - - - -

 

[Rob van Gelder]

Ken,

Sub test()
Dim i As Long, lngLastRow As Long, rng As Range

With Sheet1
lngLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lngLastRow
If IsEmpty(.Cells(i, 2).Value) Then
If Not rng Is Nothing Then CopyRangeToWKS rng
Set rng = .Rows(i)
Else
Set rng = Union(rng, .Rows(i))
End If
Next
If Not rng Is Nothing Then CopyRangeToWKS rng
End With
End Sub

Sub CopyRangeToWKS(rng As Range)
Dim wks As Worksheet

Set wks = Worksheets.Add(After:=Worksheets(Worksheets.Count))
wks.Name = rng.Cells(1).Value
wks.Cells(1, 1).Value = "Name"
wks.Cells(1, 2).Value = "ID"
wks.Cells(1, 3).Value = "Amt"
rng.Copy wks.Cells(2, 1)
End Sub


Rob

 

[Peter Atherton]

Ken

I think that this is the solution you need. However, if
there are more than 255 different items in the original
list you will get a subscript out of range message.

I could do this but you probably need the solution
quickly. Copy from option Explicit into a module

Regards
Peter

Option Explicit
Dim i As Long, nr As Long, nr2 As Long, j As Integer

Sub Test()
Dim r As Long
Dim v As Variant, c As Variant
Dim rng As Range, dest As Range
Dim wks As Worksheet
Dim nwks As Integer
Application.ScreenUpdating = False
Worksheets(1).Select
'Find how many rows in worksheet 1
nr = Sheets("Sheet1").UsedRange.Rows.Count
Set rng = Range(Cells(1, 1), Cells(nr, 1))
On Error Resume Next
For Each c In rng
' Test the previous row & add sheet if not the same
If c <> c.Offset(-1, 0) Then
Addsheet
'this line does not work
nwks = Worksheets.Count
r = Application.WorksheetFunction.CountA(Worksheets
(nwks) _
.Range("A:A")) + 1
Set dest = Worksheets(nwks).Cells(r, 1)
Range(c.Offset(, 0), c.Offset(, 4)).Copy dest
ElseIf c = c.Offset(-1, 0) Then
nwks = Worksheets.Count
r = Application.WorksheetFunction.CountA(Worksheets
(nwks) _
.Range("A:A")) + 1
Set dest = Worksheets(nwks).Cells(r, 1)
Range(c.Offset(, 0), c.Offset(, 4)).Copy dest
End If
Next c
InsrtRows
Application.ScreenUpdating = True
Worksheets(1).Select
End Sub

Sub InsrtRows()
Dim nwks As Integer
nwks = Worksheets.Count
For i = 2 To nwks
Worksheets(i).Select
Range("A1:A3").Select
Selection.EntireRow.Insert
NameSheet
Next i
End Sub

Sub NameSheet()
Dim Titles()
Titles = Array("Name", "ID", "Amt")
Range("A1:A3") = Application.WorksheetFunction.Transpose
(Titles)
With ActiveSheet
.Name = Range("A4")
End With
End Sub

Sub Addsheet()
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
End Sub

 

[Guest]

Rob, I am getting an error message and I am pretty sure
that it is caused by the fact that the data is imported
from a text file and the workbook is named "test.txt". We
get a run-time error "1004:"
Method 'Name' of object'_Worksheet' failed

When we debug, the highlighted code is "wks.Name=rng.Cells
(1).Value"

If you are still "listening" here, do you have a solution?

 

[Guest]

Peter, thank you so much for the response.
I think that I mis-lead you in my description. We do not
want to test for a change in every row.
We want to test for a blank cell in column B. If we find
one, we want to copy all the rows from that blank cell
down through the following rows until we find another
blank cell in column B.
In our example, we would want to copy rows 1 through 4 to
an new workwheet and rows 5 through 7 to a new worksheet.