Help required with a simple Loop

[Pedros]

Good morning all,

I need a little help with a simple bit of code. (VBA Novice)

Basically what I am trying to do is find the cost centre 46731JA2 in
column B and highlight it and any blank cells underneath it yellow. I
am doing this for about 60 different cost centres. The code below
seems to work fine (although I am open to suggestions as to where I may
have gone the wrong way about it) except the problem is that some of the
cost centres do no appear in every export.

The Problem is that if the cost centre does not appear in the export
the Macro runs to the bottom of the page then causes an error.

How do I make it stop and move on to searching for the next cost centre
if this occurs?

Thanks in advance

THE CODE:

Dim Found46731JA2 As String

Range("B1").Select
Found46731JA2 = ActiveCell.Value

Do Until Found46731JA2 = "46731JA2"
Found46731JA2 = ActiveCell.Offset(1, 0).Value
ActiveCell.Offset(1, 0).Activate
Loop

Selection.Interior.ColorIndex = 6
ActiveCell.Offset(1, 0).Activate

Do While ActiveCell = ""
Selection.Interior.ColorIndex = 6
ActiveCell.Offset(1, 0).Activate
Loop

 

[Bob Phillips]

Dim Found46731JA2 As String
Dim i As Long
Dim iLastRow as long

iLastRow = Cells(Rows.Count, "B").End(xlUp).Row

Found46731JA2 = "46731JA2"
For i = 1 To iLastRow
If Cells(i,"B").Value = Found46731JA2 Then
Do
i = i + 1
If Cells(i,"B").Value = "" Then
Cells(i,"B")..Interior.ColorIndex = 6
EndIf
Loop Until Cells(i,"B").Value = ""
Next i


--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

 

[Pedros]

Bob, thanks for replying.

I get the following error when I copied that code into my macro:

Compile error:

Next without For


Am I doing something wrong?
Also I assume that the .. before the interior colour line should just
be a single .?

Thanks again for your time, it is much appreciated!!!!

 

[Bob Phillips]

Sorry, my bad

Dim Found46731JA2 As String
Dim i As Long
Dim iLastRow As Long

iLastRow = Cells(Rows.Count, "B").End(xlUp).Row

Found46731JA2 = "46731JA2"
For i = 1 To iLastRow
If Cells(i, "B").Value = Found46731JA2 Then
Do
Cells(i, "B").Interior.ColorIndex = 6
i = i + 1
Loop Until Cells(i, "B").Value <> ""
End If
Next i

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

 

[Pedros]

Thanks Bob,

I have changed tact slightly.......

The code below does exactly what I want it to do. It highlights the
rows I require once it finds the right text......but...... It has an
error when the text is not contained in the spreadsheet (same problem
as before). I have tried to merge your code with the code I have
written bu have been unsuccesful.

My aim is to search through a large data set exported from a database
and cut, copy and format the data onto a new sheet.

Please help.....

Sub CutCopy()

Sheets("Base Data").Select

Dim Found4173RJAB As String

Range("B1").Select
Found4173RJAB = ActiveCell.Value

Do Until Found4173RJAB = "4173RJAB"
Found4173RJAB = ActiveCell.Offset(1, 0).Value
ActiveCell.Offset(1, 0).Activate
Loop

Rows(ActiveCell.Row).Select
ActiveCell.Offset(0, 1).Activate

FirstRow = ActiveCell.Row
ActiveCell.Offset(1, 0).Activate
Do While ActiveCell = ""
ActiveCell.Offset(1, 0).Activate
Loop
ActiveCell.Offset(-1, 0).Activate
LastRow = ActiveCell.Row
Rows(FirstRow & ":" & LastRow).Select


End Sub

 

[Bob Phillips]

Mine should work fine for that, whereas yours will loop until error if no
data. Did you try it?

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

 

[Pedros]

I tried it but couldn't get it to work.

I assume that it has something to do with me butchering it to change it
from colouring to highlighting rows.

I want it to select the row that the text is found in and then every
row under that until there it text in the cell below the cell that
contained the text I was searching for.

The text search is taking place in column b.

any ideas on how I can achieve that?

I really appreciate your time, thanks.

 

[Bob Phillips]

That is exactly what I did, or at least as I understand you. In what way
does it not work?

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

 

[Pedros]

Bob (or anyone esle that can help),

I have written out the code with a lot of descriptions to try to
clarify what I am trying to do. Basically the code below does exactly
what I want it to do from start to finish (except that it needs to be
repeated for about 30 general ledger codes) but the only problem is
that an error occurs when the general ledger code does not exist in
"Base Data" sheet.

Bob, the code that you wrote does search the sheet and does continue on
if the general ledger number cannot be found..... which is exactly what
I want it to do...... however it then colours the cells yellow. It
colours the cells in the right rows as I need selected so it is very
close to doing everything that I want........ However as you can see by
my code I want to select the rows that contain the cells your code
colours so that I can copy and paste them to a new sheet for formatting
and reporting.

I am sure that the code you provided me with will perform the task I
want it to but I have been incapable of completing it myself and need a
little help. Some basic descriptions with the code would be very
helpful and aid my development too if you are willing to provide them.

I hope I have been clear enough this time.

I am really appreciative of your time and effort and apologise for not
being clear enough.


The code:


Sub AgencyData()

'Change Export sheets name to base Data
Sheets("A").Name = "Base Data"

'A sheet "Agency Data" to paste the required exported data to.
Sheets.Add
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "Agency Data"

'Run Macro's to find, copy and paste the data
CutCopy
CutCopy1


End Sub


Sub CutCopy()

'Select the Base data sheet
Sheets("Base Data").Select

Dim Found4173RJAB As String

'Select column B
Range("B1").Select
Found4173RJAB = ActiveCell.Value

'Find the General ledger number "4173RJAB" in the Base Data Sheet
Do Until Found4173RJAB = "4173RJAB"
Found4173RJAB = ActiveCell.Offset(1, 0).Value
ActiveCell.Offset(1, 0).Activate
Loop

'Select the row containing 4173RJAB
Rows(ActiveCell.Row).Select

'Select column B in the highlighted row
ActiveCell.Offset(0, 1).Activate

'Make the current Row the first row of a row selection
FirstRow = ActiveCell.Row

'Move the Active Cell to the row underneath the 4173RJAB so that a
search can begin for the next cell below
'4173RJAB that contains text
ActiveCell.Offset(1, 0).Activate

'Search for the next cell below 4173RJAB that contains text
Do While ActiveCell = ""
ActiveCell.Offset(1, 0).Activate
Loop

'Move the Active Cell up one so that the active cell is the last blank
cell below 4173RJAB
ActiveCell.Offset(-1, 0).Activate

'Make the last blank cell below 4173RJAB the last row in the row
selection for copying and pasting
LastRow = ActiveCell.Row
'Select all rows from the first row to the last row
Rows(FirstRow & ":" & LastRow).Select

'Copy the selection and move the active cell to J1 on the Agency Data
Sheet
Selection.Copy
Sheets("Agency Data").Select
Range("J1").Select


Dim Marker As Boolean

'Find the next blank Cell in the J Column
Do While Marker = False
If ActiveCell.Value = "" Then
Marker = True
Else
ActiveCell.Offset(0, 1).Activate
End If
Loop
'Select the Row containing the next blank row in column J
Rows(ActiveCell.Row).Select

'Paste the copied data into the selected row.
ActiveSheet.Paste


End Sub


'REPEAT THE PROCESS FOR THE NEXT GENERAL LEDGER CODE AND PAST IT
UNDERNEATH THE LAST PASTED DATA
Sub CutCopy1()

Sheets("Base Data").Select

Dim Found4173AJAS As String

Range("B1").Select
Found4173AJAS = ActiveCell.Value

Do Until Found4173AJAS = "4173AJAS"
Found4173AJAS = ActiveCell.Offset(1, 0).Value
ActiveCell.Offset(1, 0).Activate
Loop

Rows(ActiveCell.Row).Select
ActiveCell.Offset(0, 1).Activate

FirstRow = ActiveCell.Row
ActiveCell.Offset(1, 0).Activate
Do While ActiveCell = ""
ActiveCell.Offset(1, 0).Activate
Loop
ActiveCell.Offset(-1, 0).Activate
LastRow = ActiveCell.Row
Rows(FirstRow & ":" & LastRow).Select

Selection.Copy
Sheets("Agency Data").Select
Range("J1").Select

Dim Marker As Boolean

Do While Marker = False
If ActiveCell.Value = "" Then
Marker = True
Else
ActiveCell.Offset(1, 0).Activate
End If
Loop
Rows(ActiveCell.Row).Select

ActiveSheet.Paste


End Sub

 

[Pedros]

I have managed to sort out the problem by using the ON Error Goto
function.

It is probably a pretty clumsy way to get around the problem but it
seems to work none the less.

If anyone would like to suggest cleaning code I would be happy to learn
from it.

Thanks for all of your time bob, much appreciated!!

 

[Bob Phillips]

Pedros,

Here is a re-written version of AgencyData and CutCopy. I haven't worked on
CutCopy1 as it seems to do the same thing.

Sub AgencyData()

'Change Export sheets name to base Data
Sheets("A").Name = "Base Data"

'A sheet "Agency Data" to paste the required exported data to.
Sheets.Add.Name = "Agency Data"

'Run Macro's to find, copy and paste the data
CutCopy
CutCopy1

End Sub


Sub CutCopy()
Const Found4173RJAB As String = "46731JA2"
Dim Marker As Boolean
Dim i As Long
Dim iStart As Long
Dim iEnd As Long
Dim rngTarget As Range
Dim iLastRow As Long
Dim wsSource As Worksheet
Dim wsTarget As Worksheet

Set wsSource = Worksheets("Base Data")
Set wsTarget = Worksheets("Agency Data")
Set rngTarget = wsTarget.Range("A1")

With wsSource

iLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
'create a dummy last row just in case
.Cells(iLastRow, "B") = "999999999999999"

For i = 1 To iLastRow

If .Cells(i, "B").Value = Found4173RJAB Then

iStart = .Cells(i, "B").Row

'loop through until we pass all blank rows
Do
i = i + 1
Loop Until .Cells(i, "B").Value <> ""

'set the pointer to the previous row, the
'last empty row
i = i - 1
iEnd = i

'copy all rows from the first to last
.Rows(iStart & ":" & iEnd).Copy rngTarget
'determine next free cell in target sheet
Set rngTarget = rngTarget.Offset(iEnd - iStart + 1, 0)

End If

Next i

'clear the dummy last row
.Cells(iLastRow, "B") = ""

End With

End Sub

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)