Help enclosing a macro in With/End With

[Lance Hoffmeyer]

I wrote the following macro in XL and it works fine. The problem
is that I want to run it from another program (SPSS). In an example
I saw in SPSS the code was enclosed in a With/End Loop:

'GetObject returns a reference to an existing app.
Set objExcelApp = GetObject(,"Excel.Application")
With objExcelApp

tablenb = tablenb +1
line1 = .Selection.Row
line2 = .Selection.Rows(.Selection.Rows.Count).Row
col1 = .Selection.Column
col2 = .Selection.Columns(.Selection.Columns.Count).Column
' Add a table number in the first line, make title bold & blue
.Cells(line1, col1)= "Table" & Str(tablenb) & " " & .Cells(line1, col1)
.cells(line1,col1).font.bold=True
.cells(line1,col1).Font.ColorIndex = 5
'Select the table lines (except the title) and group the lines
'.Range(.Cells(line1 + 1, col1), .Cells(line2 + 2, col2)).Select
'.Selection.Rows.Group
End With


The difference appears to be that a lot of the commands within the
With statement have periods before them. As you can probably tell
from my language I am not a programmer. I just try to simplify my
work with macros whenever possible. I have absolutely no idea
how to do change this and was wondering if someone could help?

Lance





Sub Strip_Discrim()

Application.ScreenUpdating = False
'find the current set of discrim tables by seaching for line that reads
'table 1, everything before this should be already formated lines
Cells.Find(What:="Table 1 Classification Function Coefficients", After:= _
ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart,
SearchOrder:=xlByRows, _ SearchDirection:=xlNext,
MatchCase:=False, SearchFormat:=False).Activate
startrow = ActiveCell.Row


ActiveCell.SpecialCells(xlLastCell).Select 'Find the last used cell in spreadsheet
LastCell = ActiveCell.Row 'Name LastRow as the number value of the row
Do While LastCell > (startrow - 1)
Rows(LastCell).Select

If Cells(LastCell, 1).Value = "" Then
Selection.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = " " Then
Selection.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = "Original" Then
Selection.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = "(Constant)" Then
Selection.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = "Table 1 Classification Function Coefficients" Then
Selection.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = "Table 2 Classification Results(a)" Then
Selection.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = "Fisher's linear discriminant functions" Then
Selection.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = "a" Then
Cells(LastCell, 1).Select
Selection.Delete Shift:=xlToLeft
End If

LastCell = LastCell - 1
Loop

Columns("A:A").Select
Selection.Replace What:=" of original grouped cases correctly classified.", _
Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:= _
False, SearchFormat:=False, ReplaceFormat:=False

Application.ScreenUpdating = True

' Need to delete only current table cells leaving rest intact
ActiveCell.SpecialCells(xlLastCell).Select 'Find the last used cell in spreadsheet
LastCell2 = ActiveCell.Row 'Name LastRow as the number value of the row

' Range(Cells(I, j + 1), Cells(I, LastCol)).Clear
Range(Cells(startrow, 2), Cells(LastCell2, 24)).Select
Selection.ClearContents

'Now, transpose values
ActiveCell.SpecialCells(xlLastCell).Select 'Find the last used cell in spreadsheet
lastcell3 = ActiveCell.Row 'Name LastRow as the number value of the row

Range(Cells(startrow, 1), Cells(lastcell3, 1)).Select
Selection.Copy
Cells(lastcell3 + 1, 1).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True

'Now, delete everything between startcell and final transposed values

Range(Cells(startrow, 1), Cells(lastcell3, 1)).Select
Application.CutCopyMode = False
Selection.EntireRow.Delete


End Sub

 

[Tom Ogilvy]

worksheets("Sheet1").Range("A1").Interior.ColorIndex = 6
worksheets("Sheet1").Range("A1").Font.Bold = True
worksheets("Sheet1").Range("A1").Font.ColorIndex = 3
worksheets("Sheet1").Range("A1").Font.Size = 12
this redundant code can be replace with a With/End With construct

With Worksheets("Sheet1").Range("A1")
.Interior.ColorIndex = 6
.Font.Bold = True
.Font.ColorIndex = 3
.Font.Size = 12
End With

the leading period means they are qualified by the object in the With
Statement.

You can Nest:

With Worksheets("Sheet1").Range("A1")
.Interior.ColorIndex = 6
With .Font
.Bold = True
.ColorIndex = 3
.Size = 12
End With
End With

 

[Bob Phillips]

Lance,

In VBA, you work down the object model when working with any part of the
Excel application. The OM starts at the Excel application itself, or
Amplification. Within VBA in Excel, this is not necessary, as it is
implicit, but when using automation, and accessing the Excel object model
from another app, you have to create an Excel object so that you can work
upon it (the Set objExcelApp = GetObject(,"Excel.Application") in your
code).

Then working down, within an application there are workbooks, windows, VBE,
and many others, which are accessed from the Application object, so you say
something like Application.Workbooks(name) or objExcelApp.Workbooks(name).
And within workbooks, you have other properties, such as worksheets, etc.
etc.

This all works fine, but if you are referring to the same property
continually, then VBA has to resolve the reference each time, and in a
complex program, this can be quite inefficient. It can be improved by using
With ... End With, as this tells VBA that any dot statements that follow the
with and before the End with will be properties of that object referenced in
the With statement, saving the effort of resolving it each time.

As well as being more efficient, it is easier to read IMO, as long as you
use good indenting. Consider this

Set objExcelApp = GetObject(,"Excel.Application")
With objExcelApp
tablenb = tablenb +1
line1 = .Selection.Row
line2 = .Selection.Rows(.Selection.Rows.Count).Row
col1 = .Selection.Column
col2 = .Selection.Columns(.Selection.Columns.Count).Column
End With

as against this
Set objExcelApp = GetObject(,"Excel.Application")
tablenb = tablenb +1
line1 = objExcelApp.Selection.Row
line2 = objExcelApp.Selection.Rows(.Selection.Rows.Count).Row
col1 = objExcelApp.Selection.Column
col2 = objExcelApp.Selection.Columns(.Selection.Columns.Count).Column

I think the former is much clearer.

In this example, the first is better written as


Set objExcelApp = GetObject(,"Excel.Application")
With objExcelApp.Selection
tablenb = tablenb +1
line1 = .Row
line2 = .Rows(.Rows.Count).Row
col1 = .Column
col2 = .Columns(.Columns.Count).Column
End With

which is even clearer and more efficient.

BTW, you can have With within a With. As an example, we could have written
this code as


Set objExcelApp = GetObject(,"Excel.Application")
With objExcelApp
tablenb = tablenb +1
With .Selection
line1 = .Row
line2 = .Rows(.Rows.Count).Row
col1 = .Column
col2 = .Columns(.Columns.Count).Column
End With
End With

which is actually more appropriate in the real code as it uses other
properties as well as Selection.

As to your code, there is not much opportunity for Withs as it stands, but
we could write that as

Sub Strip_Discrim()

Application.ScreenUpdating = False
'find the current set of discrim tables by seaching for line that reads
'table 1, everything before this should be already formated lines
Cells.Find(What:="Table 1 Classification Function Coefficients", _
After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False).Activate
startrow = ActiveCell.Row


ActiveCell.SpecialCells(xlLastCell).Select 'Find the last used cell in
spreadsheet
LastCell = ActiveCell.Row 'Name LastRow as the number value of
the row
Do While LastCell > (startrow - 1)
With Selection
Rows(LastCell).Select
If Cells(LastCell, 1).Value = "" Then
.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = " " Then
.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = "Original" Then
.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = "(Constant)" Then
.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = "Table 1 Classification
Function Coefficients" Then
.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = "Table 2 Classification
Results(a)" Then
.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = "Fisher's linear discriminant
functions" Then
.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = "a" Then
Cells(LastCell, 1).Select
Selection.Delete Shift:=xlToLeft
End If
End With
LastCell = LastCell - 1
Loop

Columns("A:A").Select
Selection.Replace What:=" of original grouped cases correctly
classified.", _
Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=
_
False, SearchFormat:=False, ReplaceFormat:=False

Application.ScreenUpdating = True

' Need to delete only current table cells leaving rest intact
ActiveCell.SpecialCells(xlLastCell).Select 'Find the last used cell in
spreadsheet
LastCell2 = ActiveCell.Row 'Name LastRow as the number value of
the row

' Range(Cells(I, j + 1), Cells(I, LastCol)).Clear
Range(Cells(startrow, 2), Cells(LastCell2, 24)).Select
Selection.ClearContents

'Now, transpose values
ActiveCell.SpecialCells(xlLastCell).Select 'Find the last used cell in
spreadsheet
lastcell3 = ActiveCell.Row 'Name LastRow as the number value of
the row

Range(Cells(startrow, 1), Cells(lastcell3, 1)).Select
Selection.Copy
Cells(lastcell3 + 1, 1).Select
Selection.PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=True

'Now, delete everything between startcell and final transposed values

Range(Cells(startrow, 1), Cells(lastcell3, 1)).Select
Application.CutCopyMode = False
Selection.EntireRow.Delete

End Sub

I just added one With, I am sure you could a few more, but of little
benefit, and I indented it more (better? ).
Note that I leave the With Seelection after the Do Loop, as it will change
every iteration of the loop, so the reference needs refreshing.

Another, more important, lesson here for you is the nasty use of Select. I
know record does this but it is highly inefficient, and not necessary. For
instance, the lines

Range(Cells(startrow, 1), Cells(lastcell3, 1)).Select
Application.CutCopyMode = False
Selection.EntireRow.Delete

are better written as

Range(Cells(startrow, 1), Cells(lastcell3, 1)).EntireRow.Delete

Application.CutCopyMode = False

the CutCopymode is only needed once at the end.

More cvan be done, and here is some more, but I haven't done the Do Loop, as
that would need me to work a bit harder at it than I have time for, but it
can be done by using some sort of index to refernce the cells to process,
not selecting them

Sub Strip_Discrim()

Application.ScreenUpdating = False
'find the current set of discrim tables by seaching for line that reads
'table 1, everything before this should be already formated lines
Cells.Find(What:="Table 1 Classification Function Coefficients", _
After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False).Activate
startrow = ActiveCell.Row

ActiveCell.SpecialCells(xlLastCell).Select 'Find the last used cell in
spreadsheet
LastCell = ActiveCell.Row 'Name LastRow as the number value of
the row
Do While LastCell > (startrow - 1)
With Selection
Rows(LastCell).Select
If Cells(LastCell, 1).Value = "" Then
.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = " " Then
.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = "Original" Then
.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = "(Constant)" Then
.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = "Table 1 Classification
Function Coefficients" Then
.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = "Table 2 Classification
Results(a)" Then
.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = "Fisher's linear discriminant
functions" Then
.EntireRow.Delete
ElseIf Cells(LastCell, 1).Value = "a" Then
Cells(LastCell, 1).Select
Selection.Delete Shift:=xlToLeft
End If
End With
LastCell = LastCell - 1
Loop

Columns("A:A").Replace _
What:=" of original grouped cases correctly classified.", _
Replacement:="", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False

Application.ScreenUpdating = True

' Need to delete only current table cells leaving rest intact
'Find the last used cell in spreadsheet
LastCell2 = ActiveCell.SpecialCells(xlLastCell).Row

' Range(Cells(I, j + 1), Cells(I, LastCol)).Clear
With Range(Cells(startrow, 2), Cells(LastCell2, 24))
.ClearContents
'Now, transpose values
lastcell3 = .SpecialCells(xlLastCell).Row
End With

Range(Cells(startrow, 1), Cells(lastcell3, 1)).Copy _
Destination:=Cells(lastcell3 + 1, 1)

'Now, delete everything between startcell and final transposed values

Range(Cells(startrow, 1), Cells(lastcell3, 1)).EntireRow.Delete

Application.CutCopyMode = False

End Sub