Search to blank and merge macro help needed

[rickyckc]

Hi everyone,

I need your excel macro expertise help. Suppose I have a column of data like this:

A1: Router A
A2: Router B
A3: Router B
A4: Router B
A5: Switch A
A6: Switch B
A7: Switch C
A8: Switch C
A9: Switch C

Now, I need a macro that will first of all, search and blank off A3, A4, A8 and A9 since they are repeating and stops when no more repeats are found. And later part is to merge A2-A4 and A7-A9. Important is the 'search & blank' and 'merge' part is not cell specified. Hope you understand what I am trying to accomplish. Thanks for your attention and time.



Best Regards,
Ricky

 

[rickyckc]

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]

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

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:

Do While Test3 <> ""

to some sort of counter like:

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]

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]

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]

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]

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]

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]

Here is the final macro:

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]

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]

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.