Search to blank and merge macro help needed

**rickyckc** · Apr 5th, 2004, 12:25 AM

Hi tactps,

Thanks for your time and attention. However, there are still a few problems with your script.

1) The number of rows to merge is not fixed to 3, some are just 2, some are 8, some are 4, etc (sorry if i have mislead you on this ). Your script also makes the last row entry to merge with 2 blank rows.

2) I need to color them differently, example router=blue, sun server=yellow, linux server=red background with yellow font, etc

3) I only need to shade columns A to D, not the whole row.

Hope you or someone else are able to help furthur.

Best Regards,
Ricky

**tactps** · Apr 5th, 2004, 02:02 AM

To take account of the uneven number of cells, this should work:

Code:

Sub macro()
Range("B3").Select
Test3 = ActiveCell.Text

Do While Test3 <> ""
Test1 = ActiveCell.Offset(0, -1).Text
Test2 = ActiveCell.Offset(-1, -1).Text
Test3 = ActiveCell.Text
If Test2 = "" Then
ReturnCell = ActiveCell.Address
    ActiveCell.Offset(0, -1).Select
        Selection.End(xlUp).Select
        Test2 = ActiveCell.Text
        Range(ReturnCell).Select
        End If
If Test1 = Test2 Then
ActiveCell.Offset(0, -1).ClearContents
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1, 0).Select
End If
Loop

Range("A2").Select
Test12 = ActiveCell.Offset(0, 1).Text

Do While Test12 <> ""
Test10 = ActiveCell.Text
Test11 = ActiveCell.Offset(1, 0).Text
Test12 = ActiveCell.Offset(0, 1).Text

If Test10 <> "" And Test11 = "" And Test12 <> "" Then
StartCell = ActiveCell.Address
ActiveCell.Offset(1, 0).Select
Do While ActiveCell.Text = ""
ActiveCell.Offset(1, 0).Select
Loop
EndCell = ActiveCell.Offset(-1, 0).Address
Range(StartCell & ":" & EndCell).Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .MergeCells = True
    End With
Else
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub

Before you start running the code, type "End" below the last row in column A, and leave column B blank, or the macro will not leave the loop. Either that or change the line:

Code:

Do While Test3 <> ""

to some sort of counter like:

Code:

Do While activecell.column < 100

Re shading:
Can you tell me what colours you want to use, and whether there is a coding criteria or whether you just want to use four colours randomly. If there is a criteria, what is it?

We're getting there I think.

**rickyckc** · Apr 5th, 2004, 02:34 AM

Hi tactps,

I can't tell exactly what your last code did but it's pretty much the same as the very first one you did.

With your very first code, i added a few simple lines like this..

Sub macro()
Range("A500").Select
Selection.End(xlUp).Select
counter = 0
Test1 = ActiveCell.Text
Test2 = ActiveCell.Offset(-1, 0).Text
Test3 = ActiveCell.Row
Do Until counter = Test3
If Test1 = Test2 Then
Selection.ClearContents
'Added by me
Range(Chr(ActiveCell.Column + 64 + 3) & Trim(Str(ActiveCell.Row))).Select
ActiveCell.Select
Selection.ClearContents
Range(Chr(ActiveCell.Column + 64 - 1) & Trim(Str(ActiveCell.Row))).Select
ActiveCell.Select
Selection.ClearContents
Range(Chr(ActiveCell.Column + 64 - 2) & Trim(Str(ActiveCell.Row))).Select
'Added by me
End If
ActiveCell.Offset(-1, 0).Select
counter = counter + 1
Test1 = ActiveCell.Text
On Error GoTo Finish
Test2 = ActiveCell.Offset(-1, 0).Text
Loop

Finish:
MsgBox ("Done")
End Sub

As for the color codes, what I want is under column C, if...

ROUTER = 37
HUB/SWITCH = 34
AIX = 4
SUN = 6
LINUX = 3 (font = 6)
NETWARE = 15
W2K = 39
NT = 41 (font = 6)
W2003 = 40

Thanks again for your time and attention and patience.

Best Regards,
Ricky

**rickyckc** · Apr 5th, 2004, 02:41 AM

Hi tactps,

Pardon me but please ignore my last remark about your very last code. Somehow I made a mistake on the copy/paste. Anyway, I tried it and it works great ! Only thing is I need to merge the part on column C (Device Type) and D (Location) as well.

Thanks !

Best regards,
Ricky

**rickyckc** · Apr 5th, 2004, 03:04 AM

Hi tactps,

I treid putting the 'End' after the last row on column A and it works fine.

But when I tried changing the line ...

Do While Test3 <> ""

to

Do While activecell.column < 200

...the loop doesn't stop

Thanks.

Best Regards,
Ricky

**rickyckc** · Apr 5th, 2004, 06:13 AM

Hi tactps,

Below is something I can use (posted earlier by Juan Pablo Gonzalez in another thread) ...

-----------------------------
Sub DoIt()
With Range("A:D").FormatConditions
.Delete
Range("A1").Activate 'Just in case
.Add Type:=xlExpression, Formula1:="=ISNUMBER(MATCH(""*red*"",1:1,0))"

.Item(1).Interior.ColorIndex = 17
End With
End Sub
-----------------------------

Best Regards,
Ricky

**tactps** · Apr 5th, 2004, 07:41 PM

Oops:

Do While activecell.column < 200
should be
Do While activecell.row < 200

My Mistake.

I'll look at the other issues and advise.

**tactps** · Apr 5th, 2004, 08:04 PM

Here is the final macro:

Code:

Sub macro()
Range("B3").Select
Test3 = ActiveCell.Text

Do While Test3 <> ""
Test1 = ActiveCell.Offset(0, -1).Text
Test2 = ActiveCell.Offset(-1, -1).Text
Test3 = ActiveCell.Text
If Test2 = "" Then
ReturnCell = ActiveCell.Address
    ActiveCell.Offset(0, -1).Select
        Selection.End(xlUp).Select
        Test2 = ActiveCell.Text
        Range(ReturnCell).Select
        End If
If Test1 = Test2 Then
ActiveCell.Offset(0, -1).ClearContents
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1, 0).Select
End If
Loop

Range("A2").Select
Test12 = ActiveCell.Offset(0, 1).Text

Do While Test12 <> ""
Test10 = ActiveCell.Text
Test11 = ActiveCell.Offset(1, 0).Text
Test12 = ActiveCell.Offset(0, 1).Text

If Test10 <> "" And Test11 = "" And Test12 <> "" Then
StartCell = ActiveCell.Address
StartCellC = ActiveCell.Offset(0, 2).Address
StartCellD = ActiveCell.Offset(0, 3).Address
ActiveCell.Offset(1, 0).Select
Do While ActiveCell.Text = ""
ActiveCell.Offset(1, 0).Select
Loop
EndCell = ActiveCell.Offset(-1, 0).Address
EndCellC = ActiveCell.Offset(-1, 2).Address
EndCellD = ActiveCell.Offset(-1, 3).Address
Range(StartCell & ":" & EndCell).Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .MergeCells = True
    End With
    
Application.DisplayAlerts = False
Range(StartCellC & ":" & EndCellC).Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .MergeCells = True
    End With
Range(StartCellD & ":" & EndCellD).Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .MergeCells = True
    End With
Application.DisplayAlerts = True
Range(StartCell).Select
Else
End If
ActiveCell.Offset(1, 0).Select
Loop

Range("A1").Select
ColourTest = Left(ActiveCell.Text, 3)
Do While ColourTest <> ""
ColourTest = Left(ActiveCell.Text, 3)
RowNumber = ActiveCell.Row
Range("A" & RowNumber & ":D" & RowNumber).Select
Select Case ColourTest
Case "Rou"
Selection.Interior.ColorIndex = 37
Case "Hub"
Selection.Interior.ColorIndex = 34
Case "AIX"
Selection.Interior.ColorIndex = 4
Case "SUN"
Selection.Interior.ColorIndex = 6
Case "Lin"
Selection.Interior.ColorIndex = 3
Selection.Font.ColorIndex = 6
Case "Net"
Selection.Interior.ColorIndex = 15
Case "W2k"
Selection.Interior.ColorIndex = 39
Case "NT"
Selection.Interior.ColorIndex = 41
Selection.Font.ColorIndex = 6
Case "W200"
Selection.Interior.ColorIndex = 41
End Select
ActiveCell.Offset(1, 0).Select
Loop
End Sub

Tested and seems to do what you want

**rickyckc** · Apr 5th, 2004, 09:46 PM

Hi tactps,

I don't know why but it just doesn't do the shading. The merging did very well. I will keep checking and see if there's anywhere I did wrong.

I did tried changing it to 'Do While activecell.row < 200' ....the looping doesn't stop either.

Say, any diff in te script if I run it on Windows NT running Excel 97 SR-2 ?

Thanks again for time and attention.

Best Regards,
Ricky

**tactps** · Apr 5th, 2004, 10:52 PM

Maybe stick to the original loop.

I am on Excel 2000 and am not sure if 97 or NT is different re shading.

Maybe you should record a macro to change the font and background colour and see if the syntax is different to mine.