Search to blank and merge macro help needed

rickyckc

rickyckc

Active Member
Joined
Apr 1, 2004
Messages
327
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.

:rolleyes:

Best Regards,
Ricky
 
Sort by date Sort by votes
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
 
Upvote 0

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
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
 
Upvote 0
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
 
Upvote 0
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.

:pray:

Best Regards,
Ricky
 
Upvote 0
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
 
Upvote 0
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!
 
Upvote 0
Hi tactps,

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

(y)

Best Regards,
Ricky
 
Upvote 0
Very happy to help :biggrin:

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

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

(y)
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question
Macro that changes cell after each copy and paste
2
Replies
11
Views
405
PeteWright
PeteWright
GomaPile
  • Question
ShowDataForm
Replies
1
Views
76
DanteAmor
DanteAmor
T
  • Solved
Making the contents of the active cell the search term, and search using that term, copy paste row, next
Replies
2
Views
179
Travis Kunnen
T
S
  • Solved
VBA to copy block of cells - keeping correct cell reference
Replies
5
Views
273
Joe4
Joe4
SaraWitch
  • Solved
Return first Monday in April from one date and first Monday in current year April if another is blank
2 3
Replies
28
Views
831
Dave Patton
D

Forum statistics

Threads
1,214,976
Messages
6,122,541
Members
449,089
Latest member
davidcom

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top