View Single Post
  #13   Report Post  
Posted to microsoft.public.excel.misc
GS[_6_] GS[_6_] is offline
external usenet poster
 
Posts: 1,182
Default Excel macro - VBA code query

In article , lid says...

Tested example...

Sub Copy_Title_Auto()
' Run to automate setting titles
Dim lLastRow&, n&, lCol&

lCol = Range("G2").Column
lLastRow = Cells(Rows.Count, lCol).End(xlUp).Row

Application.ScreenUpdating = False
For n = lLastRow To 2 Step -1
With Cells(n, lCol)
If .Value = "" And .Offset(-1).Value = "" Then
Copy_Title Cells(n, lCol)
End If
End With
Next 'n
Application.ScreenUpdating = True

End Sub

Sub Copy_Title(Optional Rng As Range)
' Dummy routine to imitate whatever this does

If Rng Is Nothing Then Set Rng = ActiveCell
Rng.Value = "Title goes here"

End Sub

Sub CopyTitle_OneTime()
' Run to manually set titles
Copy_Title
End Sub


Many thanks Garry. Have played around with this today but can't get
it running quite as I want. At present, the new macro runs well but
only inserts "Title goes here" in the appropriate cells. The
modified code now looks like this (see notes below):

Sub Copy_Title_Auto()
' Run to automate setting titles

Dim lLastRow&, n&, lCol&

lCol = Range("G2").Column
lLastRow = Cells(Rows.Count, lCol).End(xlUp).Row

Range("G3").Select
Application.ScreenUpdating = False
For n = lLastRow To 2 Step -1
With Cells(n, lCol)
If .Value = "" And .Offset(-1).Value = "" Then
Copy_Title Cells(n, lCol)
End If
End With
Next n
Application.ScreenUpdating = True

End Sub

Sub Copy_Title(Optional Rng As Range)
' Dummy routine to imitate whatever this does

Dim s As String
s = ActiveSheet.Name
If s = "By Category" Then Call Copy_Cat_Name
If s = "By Day" Then Call Copy_Day_Name
If s = "By Location" Then Call Copy_Loc_Name

If Rng Is Nothing Then Set Rng = ActiveCell
Rng.Value = "Title goes here"

End Sub


I inserted the "Range("G3").Select" line to stop macro also
displaying "Title goes here" in whatever cell is selected before the
macro is run. (G3 is always the top title box on each sheet).


So why does your loop run from last row to row2? Should be...

For n = lLastRow To 3 Step - 1

...so it doesn't execute on row2. There's no reason to select any cells
if your blocks of data always are separated by 2 blank rows!

The 2nd macro now includes the same code as the Copy_Title macro.

Any ideas please? Thanks.


Victor,
My Copy_Title sub is a dummy imitation to place dummy title text
("Title goes here") in the expected manner. I suppose now you need some
way to get the results of the 3 called routines so they can pass the
appropriate title back to the caller. I suggest you make these
functions and use a variable to store the expected title...

Sub Copy_Title(Optional Rng As Range)

Dim sTitle$
If Rng Is Nothing Then Set Rng = ActiveCell

Select Case ActiveSheet.Name
Case "By Category": sTitle = Get_Category
Case "By Day": sTitle = Get_Day
Case "By Location": sTitle = Get_Location
End Select
Rng.Value = sTitle

End Sub

...where each function returns the expected value. If these need to know
which cell is being acted on then they'll also need this as an arg...

Sub Copy_Title(Optional Rng As Range)

If Rng Is Nothing Then Set Rng = ActiveCell

Select Case ActiveSheet.Name
Case "By Category": Rng.Value = Get_Category(Rng)
Case "By Day": Rng.Value = Get_Day(Rng)
Case "By Location": Rng.Value = Get_Location(Rng)
End Select
End Sub

...where I've shown that optionally the variable 'sTitle' isn't needed.
Sample functions follow...

Function Get_Category$(Optional Rng As Range)
'whatever process this is needs to load the resulting value like so...
Get_Category = <ProcessResult
End Function

Function Get_Day$(Optional Rng As Range)
'whatever process this is needs to load the resulting value like so...
Get_Day = <ProcessResult
End Function

Function Get_Location$(Optional Rng As Range)
'whatever process this is needs to load the resulting value like so...
Get_Location = <ProcessResult
End Function

...but without seeing the actual code I can only show concept here. If
you provide the code for these routines then perhaps I can deliver an
optimized solution...

--
Garry

Free usenet access at
http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion