variable text headache

[woody1]

I need to copy the text from a cell in column A that contains a specific text string

i.e."Tech 1" to a variable number of cells in column J.

The above needs to continue until it finds a cell containing "tech 2" in column A.

For example, if A9 contains "tech 1", and A75 contains "tech 2", cells J14:J64 should

contain "tech 1".

The macro then needs to loop as above, exept finding text string ("Tech 2") copying that to

a variable number of cells in column J, and so on, until it cannot find any more instances

of ("Tech *") in column A.

The position of "tech 1", "tech 2" etc within column A is always variable, but the position

of the first line of the cell the text needs to be copied to is always constant relative to

the position of "tech 1", "tech 2" etc, (is always 9 columns accross, 5 rows down).


On finding a blank cell in column A, the macro should terminate.

Have struggled on this for several months.... is it possible ?

[Jay Petrulis]

Hi,

Try the following:

Sub test()
Dim lastrow As Long, x As Long
Dim lastcol As Integer
Dim Rng1 As Range, Rng2 As Range
Dim MyArray

With ActiveSheet
.UsedRange
lastcol = .Cells.SpecialCells(xlCellTypeLastCell).Column
lastrow = .Cells.SpecialCells(xlCellTypeLastCell).Row

Set Rng1 = .Range("A1:A" & lastrow)
.Columns(lastcol + 2).ClearContents
Rng1.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Cells(1, lastcol + 2), Unique:=True
.Cells(1, lastcol + 2).Delete shift:=xlUp

Set Rng2 = .Range(.Cells(1, lastcol + 2), .Cells(1, lastcol + 2).End(xlDown))

MyArray = Rng2.Value
.Columns(lastcol + 2).ClearContents
ReDim Preserve MyArray(1 To Rng2.Rows.Count, 1 To 3)
For x = LBound(MyArray) To UBound(MyArray)
    MyArray(x, 2) = Application.Match(MyArray(x, 1), .Range("A:A"), 0)
    MyArray(x, 3) = WorksheetFunction.CountIf(.Range("A:A"), MyArray(x, 1))
    .Cells(MyArray(x, 2), 1).Offset(5, 9).Resize(MyArray(x, 3)) = MyArray(x, 1)
Next x
End With
End Sub

Please note that I assumed two things:

1. That you have a category header row in row 1.

2. That column A is sorted (this can probably be relaxed).

Please try this out and report any problems. Please work with a copy of your data until you are comfortable with the results.

Bye,
Jay

EDIT: The code above basically copies the data to the new column. All that for nothing!

Try the following, which doesn't require the sort...

Sub test()
Dim lastrow As Long, x As Long
Dim lastcol As Integer
Dim Rng1 As Range, Rng2 As Range
Dim MyArray, RowCount As Long

With ActiveSheet
.UsedRange
lastcol = .Cells.SpecialCells(xlCellTypeLastCell).Column
lastrow = .Cells.SpecialCells(xlCellTypeLastCell).Row

Set Rng1 = .Range("A1:A" & lastrow)
.Columns(lastcol + 2).ClearContents
Rng1.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Cells(1, lastcol + 2), Unique:=True
.Cells(1, lastcol + 2).Delete shift:=xlUp

Set Rng2 = .Range(.Cells(1, lastcol + 2), .Cells(1, lastcol + 2).End(xlDown))
RowCount = Rng2.Rows.Count
MyArray = Rng2.Value
.Columns(lastcol + 2).ClearContents
ReDim Preserve MyArray(1 To Rng2.Rows.Count, 1 To 2)
For x = 1 To RowCount
    MyArray(x, 2) = Application.Match(MyArray(x, 1), .Range("A:A"), 0)
Next x

For x = 1 To RowCount - 1
    .Range(.Cells(MyArray(x, 2), 1), .Cells(MyArray(x + 1, 2) - 1, 1)).Offset(5, 9) = MyArray(x, 1)
Next x
    .Cells(MyArray(RowCount, 2), 1).Offset(5, 9) = MyArray(RowCount, 1)
End With
End Sub

[ This Message was edited by: Jay Petrulis on 2002-05-15 18:03 ]

[PHMayfield]

Try in Cell J14

=if(left(A9,4)="tech",A9,J13)

You have to drag it down as far as you data goes, and maybe modify if the 0's bug you that it will split out before the first occurrence of a "tech" cell.

[ This Message was edited by: PHMayfield on 2002-05-15 16:37 ]

[woody1]

Sorted with Left command.
Shows how little I know about Excel...
Thanks.