VBA Help (Excel 2003) - Tidying up code!!

DrH100 · Jan 10, 2012

I have some code that works and does exactly what I need it to but it occurs to me that it could be a lot tidier and easier to edit and change as required.

The code has come from various other codes and has been "cobbled together" a bit but as I say it does work.

The code(sorry for the length) is as follows

vb

 Sub Send1Sheet_ActiveWorkbook()

'Counts number of characters in email

Call Chara

'Team A
If Sheets("Form").Range("b15") = "Team A" Then

'Copy contents of message and paste over formulas
Range("a17").Copy
Range("a17").PasteSpecial xlPasteValues
Range("a20").Copy
Range("a20").PasteSpecial xlPasteValues
Range("a23").Copy
Range("a23").PasteSpecial xlPasteValues

'Clear C1 and deletes formats
Range("C1").Select
Selection.ClearContents
Selection.Borders.LineStyle = xlNone
Selection.Interior.ColorIndex = xlNone

' Replaces formats to all other cells
Range("B3,B5,b7,b9,b11,b13,b15").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With

Range("A1").Select

ThisWorkbook.Sheets(1).Copy

With ActiveWorkbook

ActiveWorkbook.SaveAs "TEAM A" & " " & "-" & " " & Range("B5") & " " & "@" & " " & Range("B13") & " " & "PAGE.xls"
Call ClearTextBox
.SendMail Recipients:="JBloggs@JBloggs.co.uk", Subject:="TEAM A - PAGE" & " " & "-" & " " & Range("B5") & " " & "-" & " " & Format(Date, "dd/mmm/yy") & " " & "@" & Format(Time, "HH:MM") & " " & “.”

.Close SaveChanges:=False

End With
Else
'Team B
If Sheets("Form").Range("b15") = "Team B" Then

'Copy contents of message and paste over formulas
Range("a17").Copy
Range("a17").PasteSpecial xlPasteValues
Range("a20").Copy
Range("a20").PasteSpecial xlPasteValues
Range("a23").Copy
Range("a23").PasteSpecial xlPasteValues

'Clear C1 and deletes formats
Range("C1").Select
Selection.ClearContents
Selection.Borders.LineStyle = xlNone
Selection.Interior.ColorIndex = xlNone

' Replaces formats to all other cells
Range("B3,B5,b7,b9,b11,b13,b15").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With

Range("A1").Select

ThisWorkbook.Sheets(1).Copy

With ActiveWorkbook

ActiveWorkbook.SaveAs "TEAM B" & " " & "-" & " " & Range("B5") & " " & "@" & " " & Range("B13") & " " & "PAGE.xls"
Call ClearTextBox
.SendMail Recipients:="TSmith@TSmith.co.uk", Subject:="TEAM B - PAGE" & " " & "-" & " " & Range("B5") & " " & "-" & " " & Format(Date, "dd/mmm/yy") & " " & "@" & Format(Time, "HH:MM") & " " & “.”

.Close SaveChanges:=False

End With
Else
'Team C
If Sheets("Form").Range("b15") = "Team C" Then

'Copy contents of message and paste over formulas
Range("a17").Copy
Range("a17").PasteSpecial xlPasteValues
Range("a20").Copy
Range("a20").PasteSpecial xlPasteValues
Range("a23").Copy
Range("a23").PasteSpecial xlPasteValues

'Clear C1 and deletes formats
Range("C1").Select
Selection.ClearContents
Selection.Borders.LineStyle = xlNone
Selection.Interior.ColorIndex = xlNone

' Replaces formats to all other cells
Range("B3,B5,b7,b9,b11,b13,b15").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With

Range("A1").Select

ThisWorkbook.Sheets(1).Copy

With ActiveWorkbook
ActiveWorkbook.SaveAs "TEAM C" & " " & "-" & " " & Range("B5") & " " & "@" & " " & Range("B13") & " " & "PAGE.xls"

Call ClearTextBox
.SendMail Recipients:="PJones@PJones.co.uk", Subject:="TEAM C - PAGE" & " " & "-" & " " & Range("B5") & " " & "-" & " " & Format(Date, "dd/mmm/yy") & " " & "@" & Format(Time, "HH:MM") & " " & "@" & Range("B13") & " " & “.”

.Close SaveChanges:=False

End With
Else
'TEAM D
If Sheets("Form").Range("b15") = "Team D" Then

'Copy contents of message and paste over formulas
Range("a17").Copy
Range("a17").PasteSpecial xlPasteValues
Range("a20").Copy
Range("a20").PasteSpecial xlPasteValues
Range("a23").Copy
Range("a23").PasteSpecial xlPasteValues

'Clear C1 and deletes formats
Range("C1").Select
Selection.ClearContents
Selection.Borders.LineStyle = xlNone
Selection.Interior.ColorIndex = xlNone

' Replaces formats to all other cells
Range("B3,B5,b7,b9,b11,b13,b15").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With

Range("A1").Select

ThisWorkbook.Sheets(1).Copy

With ActiveWorkbook
ActiveWorkbook.SaveAs "TEAM D" & " " & "-" & " " & Range("B5") & " " & "@" & " " & Range("B13") & " " & "PAGE.xls"
Call ClearTextBox

.SendMail Recipients:="PParker@PParker.co.uk.UK", Subject:="TEAM D - PAGE" & " " & "-" & " " & Range("B5") & " " & "-" & " " & Format(Date, "dd/mmm/yy") & " " & "@" & Format(Time, "HH:MM") & " " & "@" & Range("B13") & " " & “.”

.Close SaveChanges:=False

End With
Else
'Team Leader
If Sheets("Form").Range("b15") = "Team Leader" Then

'Copy contents of message and paste over formulas
Range("a17").Copy
Range("a17").PasteSpecial xlPasteValues
Range("a20").Copy
Range("a20").PasteSpecial xlPasteValues
Range("a23").Copy
Range("a23").PasteSpecial xlPasteValues

'Clear C1 and deletes formats
Range("C1").Select
Selection.ClearContents
Selection.Borders.LineStyle = xlNone
Selection.Interior.ColorIndex = xlNone

' Replaces formats to all other cells
Range("B3,B5,b7,b9,b11,b13,b15").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With

Range("A1").Select

ThisWorkbook.Sheets(1).Copy

With ActiveWorkbook
ActiveWorkbook.SaveAs "TEAM LEADER" & " " & "-" & " " & Range("B5") & " " & "@" & " " & Range("B13") & " " & "PAGE.xls"
Call ClearTextBox
.SendMail Recipients:="TeamLeaders@Team.co.uk", Subject:="TEAM LEADER - PAGE" & " " & "-" & " " & Range("B5") & " " & "-" & " " & Format(Date, "dd/mmm/yy") & " " & "@" & Format(Time, "HH:MM") & " " & "@" & Range("B13") & " " & “.”

.Close SaveChanges:=False

End With
Else
End If
End If
End If
End If
End If
Call Clear

End Sub

vb

It occurs to me that the bits in red are repeated throughout the code and only the bit in blue changes depending on what is in cell B15. If I want to make any changes to the way it runs I have to change all the occurrences in the code.

Is there anyway that the red part could appear just once and then the outcome of cell b15 could still determine which of the blue bits to work through.

I know that probably doesn't explain it very well but if anybody has any ideas on how to tidy the code and make it easier for future amendments I would be most grateful.

circledchicken · Jan 10, 2012

Hi,

You might need to tweak this a little but here are some suggestions to shorten it (note that you don't need to select cells to apply formatting, you can do it directly):

Code:

Sub Send1Sheet_ActiveWorkbook()

'Counts number of characters in email
Call Chara

' do this repeating bit first - unless there are cases where you don't want to.
' In that case put it as a seperate function and call it rather than re-writing it all for each If statement
'Copy contents of message and paste over formulas
Range("a17") = Range("a17").Value
Range("a20") = Range("a20").Value
Range("a23") = Range("a23").Value

'Clear C1 and deletes formats
With Range("C1")
    .ClearContents
    .Borders.LineStyle = xlNone
    .Interior.ColorIndex = xlNone
End With

' Replaces formats to all other cells
With Range("B3,B5,b7,b9,b11,b13,b15")
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    With .Borders
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
End With

Range("A1").Select

ThisWorkbook.Sheets(1).Copy

With ActiveWorkbook
    
    .SaveAs UCase(Sheets("Form").Range("b15")) & " " & "-" & " " & Range("B5") & " " & "@" & " " & Range("B13") & " " & "PAGE.xls"
    Call ClearTextBox

    Select Case Sheets("Form").Range("b15")
        Case "Team A" ' select Case is easier than all the If else I think
                .SendMail Recipients:="JBloggs@JBloggs.co.uk", Subject:="TEAM A - PAGE" & " " & "-" & " " & Range("B5") & " " & "-" & " " & Format(Date, "dd/mmm/yy") & " " & "@" & Format(Time, "HH:MM") & " " & “.”
        Case "Team B"
                .SendMail Recipients:="TSmith@TSmith.co.uk", Subject:="TEAM B - PAGE" & " " & "-" & " " & Range("B5") & " " & "-" & " " & Format(Date, "dd/mmm/yy") & " " & "@" & Format(Time, "HH:MM") & " " & “.”
        Case "Team C"
                .SendMail Recipients:="PJones@PJones.co.uk", Subject:="TEAM C - PAGE" & " " & "-" & " " & Range("B5") & " " & "-" & " " & Format(Date, "dd/mmm/yy") & " " & "@" & Format(Time, "HH:MM") & " " & "@" & Range("B13") & " " & “.”
        Case "Team D"
                .SendMail Recipients:="PParker@PParker.co.uk.UK", Subject:="TEAM D - PAGE" & " " & "-" & " " & Range("B5") & " " & "-" & " " & Format(Date, "dd/mmm/yy") & " " & "@" & Format(Time, "HH:MM") & " " & "@" & Range("B13") & " " & “.”
        Case "Team Leader"
                .SendMail Recipients:="TeamLeaders@Team.co.uk", Subject:="TEAM LEADER - PAGE" & " " & "-" & " " & Range("B5") & " " & "-" & " " & Format(Date, "dd/mmm/yy") & " " & "@" & Format(Time, "HH:MM") & " " & "@" & Range("B13") & " " & “.”
        ' include a Case Else if necessary
    End Select
    
    .Close SaveChanges:=False

End With

Call Clear

End Sub

DrH100 · Jan 11, 2012

Thanks circledchicken I've amended it slightly so that I understand it a bit more but it works wonderfully thank you very much.

As an aside, can you tell me how you managed to put your code in scrolling format. That would have made my post much easier to understand?

circledchicken · Jan 11, 2012

Your welcome.

Sure, you need to wrap it in CODE tags by selecting all the code and pressing the # button at the top menu of the editor where you write the message - in line with the Bold, Italic etc. buttons).

VBA Help (Excel 2003) - Tidying up code!!

DrH100

Board Regular

Excel Facts

circledchicken

Well-known Member

DrH100

Board Regular

circledchicken

Well-known Member

Similar threads

Forum statistics

Share this page

VBA Help (Excel 2003) - Tidying up code!!

DrH100

Board Regular

Excel Facts

circledchicken

Well-known Member

DrH100

Board Regular

circledchicken

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock