Excel Search to blank and merge macro help needed from Mr Excel


 FAQFAQ
   SearchSearch   MemberlistMemberlist   UsergroupsUsergroups   FavoritesFavorites   StatisticsStatistics 
 RegisterRegister 
 ProfileProfile   Log in to check your private messagesLog in to check your private messages   Log inLog in 
Online StoreOnline Store

MrExcel Message Board Forum Index -> Excel Questions

Search to blank and merge macro help needed
Post new topic   Reply to topic
Last Thread | Next Thread  >   Printable version
  Author    Thread

rickyckc
Board Regular


Joined: 02 Apr 2004
Posts: 41
Location: Singapore
Flag: Singapore

Status: Offline

 Reply with quote  

Search to blank and merge macro help needed

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.

icon_rolleyes.gif

Best Regards,
Ricky

Post Fri Apr 02, 2004 2:40 am 
 View user's profile Send private message

Juan Pablo González
MrExcel MVP


Joined: 09 Feb 2002
Posts: 8853
Location: Marion, IL
Flag: Colombia

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

You only clear it if the cell above is the same ? for example, you won't clear A5 or A6 even they appear above on the list ?
_________________
Regards,

Juan Pablo González
MrExcel.com Consulting

Read the Articles List and check out our Recommended links and Add-Ins

Post Fri Apr 02, 2004 3:47 am 
 View user's profile Send private message Visit poster's website

tactps
Board Master


Joined: 20 Jan 2004
Posts: 419
Location: Melbourne
Flag: Australia

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

Assuming your list is sorted, try this (not neat but will work):

code:
Sub macro()
Range("A100").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
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



_________________
There are 2 kinds of people.... those who divide people into 2 kinds and those who don't.

Post Fri Apr 02, 2004 3:50 am 
 View user's profile Send private message

rickyckc
Board Regular


Joined: 02 Apr 2004
Posts: 41
Location: Singapore
Flag: Singapore

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

Hi Juan Pablo González,

Yes, correct

Hi tactps,

Thanks, will try it out

Post Fri Apr 02, 2004 5:47 am 
 View user's profile Send private message

rickyckc
Board Regular


Joined: 02 Apr 2004
Posts: 41
Location: Singapore
Flag: Singapore

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

Hi tactps,

I have tried yur scripts, works great but I still have 3 questions :P

1) Your script will not work if the column A is not sorted, corect ?
(sorry, I have not tried that out yet)

2) I need to set the range ? Can it somehow be 'auto' (meaning no need to set range)

3) How about the merge part ? Based on my column example, I need to merge A2, A3 and A4 together as one cell.

Thanks again.

Best Regards,
Ricky

Post Fri Apr 02, 2004 6:02 am 
 View user's profile Send private message

rickyckc
Board Regular


Joined: 02 Apr 2004
Posts: 41
Location: Singapore
Flag: Singapore

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

BTW, how am i able ti attach a sample file ? Any idea ?

Best Regards,
Ricky

Post Fri Apr 02, 2004 6:06 am 
 View user's profile Send private message

tactps
Board Master


Joined: 20 Jan 2004
Posts: 419
Location: Melbourne
Flag: Australia

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed


quote:


Your post:
1) Your script will not work if the column A is not sorted, corect ?
(sorry, I have not tried that out yet)

2) I need to set the range ? Can it somehow be 'auto' (meaning no need to set range)

3) How about the merge part ? Based on my column example, I need to merge A2, A3 and A4 together as one cell.


Re:
1) - correct. you would need to sort the code in column A
2) - I have it going to the bottom of column A (assuming that you have less than 100 rows).
If not, change:
Range("A100").Select
to
Range("A60000").select

3) I am not sure what you mean by merge. Do you have data in other columns?

Perhaps you need to post your spreadsheet (details changed to protect the guilty) using Colo's HTML Maker (bottom of screen).

Then I'm sure we can help you out better.
icon_biggrin.gif
_________________
There are 2 kinds of people.... those who divide people into 2 kinds and those who don't.

Post Fri Apr 02, 2004 6:13 am 
 View user's profile Send private message

rickyckc
Board Regular


Joined: 02 Apr 2004
Posts: 41
Location: Singapore
Flag: Singapore

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

Hi tactps,

I have created a html sample .....DUH.....now how do I post/show it ?

icon_banghead.gif

Best Regards,
Ricky

Post Fri Apr 02, 2004 6:58 am 
 View user's profile Send private message

rickyckc
Board Regular


Joined: 02 Apr 2004
Posts: 41
Location: Singapore
Flag: Singapore

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

Hi tactps,

Microsoft Excel - sample.xls___Running: xl2000 : OS = Windows 98
(F)ile (E)dit (V)iew (I)nsert (O)ptions (T)ools (D)ata (W)indow (H)elp (A)bout
=

A
B
C
D
1
HostnameIP AddressDevice TypeLocation
2
AIX_Server_A4.3.2.1AXIHong Kong
3
Switch_A5.6.7.8SWITCHSingapore
4
Switch_A5.6.8.7SWITCHSingapore
5
Switch_A5.6.8.9SWITCHSingapore
6
Netware_Server_A1.1.1.1NETWAREJapan
7
Router_A6.7.3.4ROUTERUSA
8
Router_A6.7.8.9ROUTERUSA
9
Router_A6.7.9.8ROUTERUSA
10
SUN_Server_A2.2.2.2SUNKorea
11
Linux_Server_A3.3.3.3LINUXAustralia
12
Router_B9.8.7.6ROUTERThailand
13
Router_B9.8.1.2ROUTERThailand
14
Router_B9.8.3.4ROUTERThailand
15
    
16
HostnameIP AddressDevice TypeLocation
17
AIX_Server_A4.3.2.1AXIHong Kong
18
Switch_A5.6.7.8SWITCHSingapore
19
5.6.8.7
20
5.6.8.9
21
Netware_Server_A1.1.1.1NETWAREJapan
22
Router_A6.7.3.4ROUTERUSA
23
6.7.8.9
24
6.7.9.8
25
SUN_Server_A2.2.2.2SUNKorea
26
Linux_Server_A3.3.3.3LINUXAustralia
27
Router_B9.8.7.6ROUTERThailand
28
9.8.1.2
29
9.8.3.4
All Devices 

[HtmlMaker 2.42] To see the formula in the cells just click on the cells hyperlink or click the Name box
PLEASE DO NOT QUOTE THIS TABLE IMAGE ON SAME PAGE! OTHEWISE, ERROR OF JavaScript OCCUR.


OK. I have managed to figure it out how to post the html file.

Now.....the top portion is the raw file

and the bottom portion is my preferred final output

Thanks.

Best Regards,
Ricky

Post Fri Apr 02, 2004 7:53 am 
 View user's profile Send private message

tactps
Board Master


Joined: 20 Jan 2004
Posts: 419
Location: Melbourne
Flag: Australia

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

This should be close to what you want. I'm sure an MVP out there can clean it up a fair bit as it is far longer than it needs to be:

code:
Sub macro()
Range("A100").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
End If
ActiveCell.Offset(-1, 0).Select
counter = counter + 1
Test1 = ActiveCell.Text
On Error GoTo Step2
Test2 = ActiveCell.Offset(-1, 0).Text
Loop


Step2:
Range("A1").Select
countermerge = 0
Do While countermerge < 100
On Error GoTo Finish
Merge1 = ActiveCell.Text
Merge2 = ActiveCell.Offset(1, 0).Text
Merge3 = ActiveCell.Offset(2, 0).Text
Merge4 = ActiveCell.Address
Merge5 = ActiveCell.Offset(2, 0).Address

If Merge1 <> "" And Merge2 = "" And Merge3 = "" Then
Range(Merge4 & ":" & Merge5).Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .MergeCells = True
    End With
If Selection.Interior.ColorIndex = ActiveCell.Offset(-1, 0).Interior.ColorIndex Then
If Selection.Interior.ColorIndex = xlNone Then
Selection.EntireRow.Select
Selection.Interior.ColorIndex = 6
Else
ActiveCell.EntireRow.Select
Selection.Interior.ColorIndex = xlNone
End If
End If
End If

countermerge = countermerge + 1
ActiveCell.Offset(1, 0).Select
Loop

Finish:
MsgBox ("Done")
End Sub



_________________
There are 2 kinds of people.... those who divide people into 2 kinds and those who don't.

Post Mon Apr 05, 2004 12:46 am 
 View user's profile Send private message

rickyckc
Board Regular


Joined: 02 Apr 2004
Posts: 41
Location: Singapore
Flag: Singapore

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

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.

icon_beerchug.gif

Best Regards,
Ricky

Post Mon Apr 05, 2004 4:25 am 
 View user's profile Send private message

tactps
Board Master


Joined: 20 Jan 2004
Posts: 419
Location: Melbourne
Flag: Australia

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

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.
icon_biggrin.gif
_________________
There are 2 kinds of people.... those who divide people into 2 kinds and those who don't.

Post Mon Apr 05, 2004 6:02 am 
 View user's profile Send private message

rickyckc
Board Regular


Joined: 02 Apr 2004
Posts: 41
Location: Singapore
Flag: Singapore

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

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

Post Mon Apr 05, 2004 6:34 am 
 View user's profile Send private message

rickyckc
Board Regular


Joined: 02 Apr 2004
Posts: 41
Location: Singapore
Flag: Singapore

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

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

Post Mon Apr 05, 2004 6:41 am 
 View user's profile Send private message

rickyckc
Board Regular


Joined: 02 Apr 2004
Posts: 41
Location: Singapore
Flag: Singapore

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

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

Post Mon Apr 05, 2004 7:04 am 
 View user's profile Send private message

rickyckc
Board Regular


Joined: 02 Apr 2004
Posts: 41
Location: Singapore
Flag: Singapore

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

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

Post Mon Apr 05, 2004 10:13 am 
 View user's profile Send private message

tactps
Board Master


Joined: 20 Jan 2004
Posts: 419
Location: Melbourne
Flag: Australia

Status: Offline

 Reply with quote  

Oops:

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

My Mistake.

I'll look at the other issues and advise.
_________________
There are 2 kinds of people.... those who divide people into 2 kinds and those who don't.

Post Mon Apr 05, 2004 11:41 pm 
 View user's profile Send private message

tactps
Board Master


Joined: 20 Jan 2004
Posts: 419
Location: Melbourne
Flag: Australia

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

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
icon_beerchug.gif
_________________
There are 2 kinds of people.... those who divide people into 2 kinds and those who don't.

Post Tue Apr 06, 2004 12:04 am 
 View user's profile Send private message

rickyckc
Board Regular


Joined: 02 Apr 2004
Posts: 41
Location: Singapore
Flag: Singapore

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

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

Post Tue Apr 06, 2004 1:46 am 
 View user's profile Send private message

tactps
Board Master


Joined: 20 Jan 2004
Posts: 419
Location: Melbourne
Flag: Australia

Status: Offline

 Reply with quote  

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.
_________________
There are 2 kinds of people.... those who divide people into 2 kinds and those who don't.

Post Tue Apr 06, 2004 2:52 am 
 View user's profile Send private message

rickyckc
Board Regular


Joined: 02 Apr 2004
Posts: 41
Location: Singapore
Flag: Singapore

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

Hi tactps,

I tested it on my Excel 2000. No coloring too.

Just before the merge part, I did saw in a sec one/some cell are colored purple, but then it is back to plain white.

How to make the macro run slowler / step by step ?

Thanks.

Best Regards,
Ricky

Post Tue Apr 06, 2004 3:09 am 
 View user's profile Send private message

rickyckc
Board Regular


Joined: 02 Apr 2004
Posts: 41
Location: Singapore
Flag: Singapore

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

Hi tactps,

I thing I did play around is change...

Range("A" & RowNumber & ":D" & RowNumber).Select

to

Range("C" & RowNumber & ":D" & RowNumber).Select

What happened is, it did color perfectly but only on column C and D

Thanks.

Best Regards,
Ricky

Post Tue Apr 06, 2004 3:14 am 
 View user's profile Send private message

tactps
Board Master


Joined: 20 Jan 2004
Posts: 419
Location: Melbourne
Flag: Australia

Status: Offline

 Reply with quote  

Should have worked (works fine on my PC).

To run the macro slower (called debug):
Press Alt-F11. This will open up the VBA window.
On the left, double click on the module (module1)
On the right, you will see the macro.
Press F8 to step through macro.

You can also put in this event handler (a macro attached to the workbook) before you run the macro:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 1 And ActiveCell.Interior.ColorIndex = xlNone Then
ActiveCell.Interior.ColorIndex = ActiveCell.Offset(0, 2).Interior.ColorIndex
ActiveCell.Font.ColorIndex = ActiveCell.Offset(0, 2).Font.ColorIndex
End If
End Sub

Getting there I think
_________________
There are 2 kinds of people.... those who divide people into 2 kinds and those who don't.

Post Tue Apr 06, 2004 3:36 am 
 View user's profile Send private message

rickyckc
Board Regular


Joined: 02 Apr 2004
Posts: 41
Location: Singapore
Flag: Singapore

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

Hi tactps,

I did all what you said, still no go. I think my excel hates me :(

It's okay if you wanna give up on me. And I will keep trying to find out what/where it went wrong. I will just do the shading manually for now.

Anyway, I am naming my macro 'tactps' to remember your time and effort.

Thanks for everything.

icon_pray.gif

Best Regards,
Ricky

Post Tue Apr 06, 2004 4:59 am 
 View user's profile Send private message

tactps
Board Master


Joined: 20 Jan 2004
Posts: 419
Location: Melbourne
Flag: Australia

Status: Offline

 Reply with quote  

Anytime... I feel honoured!
_________________
There are 2 kinds of people.... those who divide people into 2 kinds and those who don't.

Post Tue Apr 06, 2004 6:15 am 
 View user's profile Send private message

rickyckc
Board Regular


Joined: 02 Apr 2004
Posts: 41
Location: Singapore
Flag: Singapore

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

Hi tactps,

Just to let you know, if I changed one of the text under column A to 'Router', it will shade column A to D nicely. Meaning it is looking for 'rou' under column A instead of under column C

Thanks.

Best Regards,
Ricky

Post Tue Apr 06, 2004 7:56 am 
 View user's profile Send private message

tactps
Board Master


Joined: 20 Jan 2004
Posts: 419
Location: Melbourne
Flag: Australia

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

Ther colour codes you gave me were:

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

I thought these were in column A, not column C.

I have adjusted the code to look at column C, but you will need to change the "Cases" to those listed in column C, not column A

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("C1").Select
ColourTest = Left(ActiveCell.Text, 3)
Do While ColourTest <> ""
ColourTest = Left(ActiveCell.Text, 3)
ReturnCellCol = ActiveCell.Address
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
Range(ReturnCellCol).Select
ActiveCell.Offset(1, 0).Select
Loop
End Sub




Good luck!
_________________
There are 2 kinds of people.... those who divide people into 2 kinds and those who don't.

Post Tue Apr 06, 2004 11:00 pm 
 View user's profile Send private message

rickyckc
Board Regular


Joined: 02 Apr 2004
Posts: 41
Location: Singapore
Flag: Singapore

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

Hi tactps,

It works perfectly ! Thanks alot for all your time spent on my problem !

icon_beerchug.gif

Best Regards,
Ricky

Post Wed Apr 07, 2004 1:54 am 
 View user's profile Send private message

tactps
Board Master


Joined: 20 Jan 2004
Posts: 419
Location: Melbourne
Flag: Australia

Status: Offline

 Reply with quote  

Re: Search to blank and merge macro help needed

Very happy to help icon_biggrin.gif

I'm just annoyed with myself that it took me so long to fathom what you needed. icon_cry.gif

The code I gave you is much longer than it needs to be, but if it ain't broke, don't fix it!!!! icon_laugh.gif

icon_beerchug.gif
_________________
There are 2 kinds of people.... those who divide people into 2 kinds and those who don't.

Post Wed Apr 07, 2004 1:58 am 
 View user's profile Send private message
  Display posts from previous:      

MrExcel Message Board Forum Index -> Excel Questions


Forum Jump:
Jump to:  

Post new topic   Reply to topic
Page 1 of 1



Add To Favorites

 


Forum Rules:
You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum
You cannot vote in polls in this forum

Powered by phpBB: 2.0.4 © 2001 phpBB Group

Need help posting your first question? Read how to post

Need extra help ? Couldn't get the answer you needed ? Get a free quote from our Consulting Team

Download Colo's HTML Maker utility for displaying your Excel Worksheet on the board.

Download VB HTML Maker to post your code on the board


Check out our new index to 485 Excel Articles.


Return to MrExcel Consulting

All contents Copyright 1998-2004 by MrExcel.com
If you believe information posted here is from your copyrighted source, notify us per the Terms of Use
Excel is a registered trademark of the Microsoft Corporation.
MrExcel is a registered trademark of Tickling Keys, Inc.