Find function in VBA

Z

zackii

New Member
Joined
Nov 12, 2014
Messages
22
I've tried for a few hours but have failed to accomplish what I am after so any help would be greatly appreciated PLEASE.

Here's the data that I am working with (details follow after the table):

Activity CodeDescription
Boston_Corporate

<tbody>
</tbody>
T100
Boston_CorporateT2EQ
Oahu_PVP

<tbody>
</tbody>
T2w
Oahu_PVPT3q
Oahu_PVPT585
Oahu_PVPT6qw
Oahu_PVPT7w
Overhead_General

<tbody>
</tbody>
T8ty
Overhead_General

<tbody>
</tbody>
T9af
Overhead_General

<tbody>
</tbody>
T10855

<tbody>
</tbody>


The first row is the header row.
I am trying to write a macro that;
  1. Searches for the first UNIQUE value in Column A (it's Boston_Corporate right now) and then add a blank row after that.
  2. Searches for the second UNIQUE value in Column A (it's Oahu_PVP right now) and then add a blank row after that.
  3. Searches for the third UNIQUE value in Column A (it's Overhead_General right now) and then add a blank row after that.
  4. The macro continues to do so until it has 'actioned' all unique values in Column A

Worth mentioning:
The data will always be sorted by Column A beforehand.
There may be 100s of rows involved with hundreds of unique values in Column A so values cannot be hardcoded in the macro (need to be dynamic)
 

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
Sort by date Sort by votes
Re: Need help with the Find function in VBA

Try:
Code: 
Sub InsertRows()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
        With ActiveSheet
            For r = .Range("A" & Rows.Count).End(xlUp).Row To [COLOR=#ff0000]2[/COLOR] Step -1
                If .Cells(r - 1, 1) <> .Cells(r, 1) Then Rows(r).Insert
            Next
        End With
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Assumes data starts in row 2
 
Last edited:
Upvote 0
Re: Need help with the Find function in VBA

Yongle said:
Try:
Code: 
Sub InsertRows()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
        With ActiveSheet
            For r = .Range("A" & Rows.Count).End(xlUp).Row To [COLOR=#ff0000]2[/COLOR] Step -1
                If .Cells(r - 1, 1) <> .Cells(r, 1) Then Rows(r).Insert
            Next
        End With
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Assumes data starts in row 2
Click to expand...

Thanks Yongle. That code does work but partially.
a) Is there a way to prevent it from adding a blank row after the header?
b) How can I modify the code so that it ads 2 rows instead of 1

Thanks again for your help!
 
Upvote 0
Re: Need help with the Find function in VBA

a) Is there a way to prevent it from adding a blank row after the header?
YES - end loop at row 3 instead of row 2
(value in row 3 and row 2 compared - if the same, then rows are not inserted)
Code: 
For r = .Range("A" & Rows.Count).End(xlUp).Row To [COLOR=#ff0000]3[/COLOR] Step -1

b) How can I modify the code so that it adds 2 rows instead of 1?
replace:
Code: 
Rows(r).insert
with:
Code: 
Rows(r).Resize(2).insert
 
Last edited:
Upvote 0
Re: Need help with the Find function in VBA

That works like a charm. Thank you so so much Yongle. Can I pester you for one last fix please?

Is there a way to merge and center duplicate values in Column A (so that each unique value is only listed once) PLUS the blank cell that follows. To elaborate, see the table below for what the data looks like after blank rows have been added (using the macro from yesterday). For this data set, the cells A1:A3 would get merged (the value in the merged cell would be Boston_Corporate), cells A5:A10 would get merged (the value in the merged cell would be Oahu_PVP), cells A12:A15 would get merged (the value in the merged cell would be Overhead_General).

Of course the data is dynamic and hence the code should be able to cope for additional rows/unique values in column A.

Activity CodeDescription
Boston_CorporateT100
Boston_CorporateT2EQ
Oahu_PVPT2w
Oahu_PVPT3q
Oahu_PVPT585
Oahu_PVPT6qw
Oahu_PVPT7w
Overhead_GeneralT8ty
Overhead_GeneralT9af
Overhead_GeneralT10855

<tbody>
</tbody>

Thanks again for all your help so far :)
 
Upvote 0
Re: Need help with the Find function in VBA

Run this after InsertRows
Code: 
Sub MergeCells()
    Dim LastCell As Range, FirstCell As Range
    
    With ActiveSheet
'identify Cells to be merged
        Set LastCell = .Range("A" & Rows.Count).End(xlUp)
            Do Until LastCell.Row = 1
    
                Set FirstCell = LastCell.Offset(-1)
                    If IsEmpty(LastCell.Offset(-1).Value) Then
                        Set FirstCell = LastCell
                    Else
                        Set FirstCell = LastCell.End(xlUp)
                    End If
                If FirstCell.Row = 1 Then Set FirstCell = FirstCell.Offset(1)
                Set LastCell = LastCell.Offset(1)
 'merge snd centre
                Application.DisplayAlerts = False
                    With Range(FirstCell, LastCell)
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .Merge
                    End With
                 Application.DisplayAlerts = True
                Set LastCell = FirstCell.End(xlUp)
            Loop
    End With

End Sub

Of course the data is dynamic and hence the code should be able to cope for additional rows/unique values in column A
Click to expand...
YES and NO!

:eek: Merging cells makes life more difficult
To make the code dynamic
- retain a second worksheet with ALL the data and add new rows to that
- apply VBA to a copy of that sheet
 
Upvote 0
Re: Need help with the Find function in VBA

Yongle said:
Run this after InsertRows
Code: 
Sub MergeCells()
    Dim LastCell As Range, FirstCell As Range
    
    With ActiveSheet
'identify Cells to be merged
        Set LastCell = .Range("A" & Rows.Count).End(xlUp)
            Do Until LastCell.Row = 1
    
                Set FirstCell = LastCell.Offset(-1)
                    If IsEmpty(LastCell.Offset(-1).Value) Then
                        Set FirstCell = LastCell
                    Else
                        Set FirstCell = LastCell.End(xlUp)
                    End If
                If FirstCell.Row = 1 Then Set FirstCell = FirstCell.Offset(1)
                Set LastCell = LastCell.Offset(1)
 'merge snd centre
                Application.DisplayAlerts = False
                    With Range(FirstCell, LastCell)
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .Merge
                    End With
                 Application.DisplayAlerts = True
                Set LastCell = FirstCell.End(xlUp)
            Loop
    End With

End Sub
Click to expand...
You can write your MergeCells macro more compactly this way...
Code: 
[table="width: 500"]
[tr]
	[td]Sub MergeCells()
  Dim Ar As Range
  For Each Ar In Range("A2", Cells(Rows.Count, "A").End(xlUp)).SpecialCells(xlConstants).Areas
    If Ar.Count > 1 Then
      Ar.Offset(1).Resize(Ar.Count - 1).ClearContents
      Ar.Merge
    End If
    Ar.HorizontalAlignment = xlCenter
    Ar.VerticalAlignment = xlCenter
  Next
End Sub[/td]
[/tr]
[/table]
 
Upvote 0
Re: Need help with the Find function in VBA

@Rick Rothstein - nice abbrevaition :)
@zackii - note the amendment to add in the extra row as requested

Code: 
Sub MergeCells2()
  Dim Ar As Range
  For Each Ar In Range("A2", Cells(Rows.Count, "A").End(xlUp)).SpecialCells(xlConstants).Areas
    If Ar.Count > 1 Then
      Ar.Offset(1).Resize(Ar.Count - 1).ClearContents
      [COLOR=#ff0000]Ar.Resize(Ar.Count + 1).Merge[/COLOR]
    End If
    Ar.HorizontalAlignment = xlCenter
    Ar.VerticalAlignment = xlCenter
  Next
End Sub
 
Upvote 0
Re: Need help with the Find function in VBA

Yongle said:
@Rick Rothstein - nice abbrevaition :)
@zackii - note the amendment to add in the extra row as requested

Code: 
Sub MergeCells2()
  Dim Ar As Range
  For Each Ar In Range("A2", Cells(Rows.Count, "A").End(xlUp)).SpecialCells(xlConstants).Areas
    If Ar.Count > 1 Then
      Ar.Offset(1).Resize(Ar.Count - 1).ClearContents
      [COLOR=#ff0000]Ar.Resize(Ar.Count + 1).Merge[/COLOR]
    End If
    Ar.HorizontalAlignment = xlCenter
    Ar.VerticalAlignment = xlCenter
  Next
End Sub
Click to expand...
I missed the part about including the blank cell under the last activity code per area. Given that, the structure of my code and, hence, your fix are not exactly correct... the If..Then block, as constructed, was meant to ignore single line activity codes, but since the blank under it would need to be merged, the structure of that If..Then block is not correct. Here is the correct code so that single line activity codes are handled properly...
Code: 
[table="width: 500"]
[tr]
	[td]Sub MergeCells()
  Dim Ar As Range
  For Each Ar In Range("A2", Cells(Rows.Count, "A").End(xlUp)).SpecialCells(xlConstants).Areas
    If Ar.Count > 1 Then Ar.Offset(1).Resize(Ar.Count - 1).ClearContents
    Ar.Resize(Ar.Count + 1).Merge
    Ar.HorizontalAlignment = xlCenter
    Ar.VerticalAlignment = xlCenter
  Next
End Sub[/td]
[/tr]
[/table]
 
Upvote 0
Re: Need help with the Find function in VBA

Rick Rothstein said:
I missed the part about including the blank cell under the last activity code per area. Given that, the structure of my code and, hence, your fix are not exactly correct... the If..Then block, as constructed, was meant to ignore single line activity codes, but since the blank under it would need to be merged, the structure of that If..Then block is not correct. Here is the correct code so that single line activity codes are handled properly...
Code: 
[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub MergeCells()
  Dim Ar As Range
  For Each Ar In Range("A2", Cells(Rows.Count, "A").End(xlUp)).SpecialCells(xlConstants).Areas
    If Ar.Count > 1 Then Ar.Offset(1).Resize(Ar.Count - 1).ClearContents
    Ar.Resize(Ar.Count + 1).Merge
    Ar.HorizontalAlignment = xlCenter
    Ar.VerticalAlignment = xlCenter
  Next
End Sub[/TD]
[/TR]
</tbody>[/TABLE]
Click to expand...

Thanks you fellas. This has been immensely helpful.
@Rick Rothstein; how can I modify that code such that it still works if there are only 2 rows of data, the first row being the header row. Please see below:

Activity CodeDescription
Boston_CorporateT100

<tbody>
</tbody>

It should still merge cell A1 and A2 please.

Again, thanks a million for all the help so far.
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Solved
Making the contents of the active cell the search term, and search using that term, copy paste row, next
Replies
2
Views
197
Travis Kunnen
T
S
  • Question
VBA Code- finding #Spill and moving the formula to the next column
Replies
0
Views
461
stromnoexcel
S
B
  • Solved
vba code to give next Sunday date for pasted data
Replies
2
Views
214
bh24524
B
M
  • Question
VLOOKUP help - return value if two partial matches are met (I think??)
Replies
5
Views
350
MountainFog
M
B
  • Solved
VBA solution for a tally sheet, add 1 to a cell based on current date
2
Replies
10
Views
152
Burrgogi
B

Forum statistics

Threads
1,215,584
Messages
6,125,670
Members
449,248
Latest member
wayneho98

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