Shorten a Macro

M

mully

Hi All ---- Seasons Greetings

Below is a macro I recorded it goes on for 23 Sheets --- I'm only showing
the 1st three sheets in the macro--- is there a way of cutting down on all
the code that is needed to run the full macro.

Sheets("RPRA").Select
Columns("E:E").Select
Selection.TextToColumns Destination:=Range("G1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True,
Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=True,
FieldInfo:= _
Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)),
TrailingMinusNumbers:= _
True

Range("I316:J323").Select
Selection.Copy
Sheets("OLD GLOSSOP").Select
Range("Z2").Select
ActiveSheet.Paste
With Selection.Interior
.ColorIndex = 40
.Pattern = xlSolid
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Font
.Name = "Times New Roman"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Sheets("RPRA").Select
Range("I324:J338").Select
Selection.Copy
Sheets("PACKMOOR").Select
Range("Z2").Select
ActiveSheet.Paste
With Selection.Interior
.ColorIndex = 40
.Pattern = xlSolid
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Font
.Name = "Times New Roman"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Sheets("RPRA").Select
Range("I2:J19").Select
Selection.Copy
Sheets("ALTON").Select
Range("Z2").Select
ActiveSheet.Paste
With Selection.Interior
.ColorIndex = 40
.Pattern = xlSolid
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Font
.Name = "Times New Roman"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub


Any Help Appreciated

Cheers

Mully
 
R

Rich

am no expert but something like

Sheets("RPRA").Select
Columns("E:E").Select
For n = 1 To Sheets.Count
Sheets(n).Range("Z2").Select
ActiveSheet.Paste
Next n

but this will only work if copying the same info into everypage
 
D

Duke Carey

Since most of the code involves formatting - or perhaps it'd be more accurate
to call it RE-FORMATTING - the cells that you are pasting into, one quick way
to simplify the code would be to avoid pasting. You could do a Paste Special
-> Values instead.

So.. this code:

Range("I316:J323").Copy
Sheets("OLD GLOSSOP").Range("Z2")..PasteSpecial xlPasteValues

would replace all of this:

Range("I316:J323").Select
Selection.Copy
Sheets("OLD GLOSSOP").Select
Range("Z2").Select
ActiveSheet.Paste
With Selection.Interior
.ColorIndex = 40
.Pattern = xlSolid
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Font
.Name = "Times New Roman"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
 
B

Bob Phillips

Split the common stuff into a separate procedure, remove all the default
settings etc.

For example

Sheets("RPRA").Select
Columns("E:E").TextToColumns Destination:=Range("G1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, _
Tab:=False, Semicolon:=False, Comma:=True,
_
Space:=False, Other:=True, _
FieldInfo:=Array(Array(1, 1), Array(2, 1),
_
Array(3, 1), Array(4, 1)), _
TrailingMinusNumbers:=True

FormatSheet Range("I316:J323"), Sheets("OLD GLOSSOP").Range("Z2")

FormatSheet Range("I324:J338"), Sheets("PACKMOOR").Range("Z2")

FormatSheet Range("I2:J19"), Sheets("ALTON").Range("Z2")
End Sub

Sub FormatSheet(Source As Range, Target As Range)
Sheets("RPRA").Source.Copy Target
With Target
.Interior
.ColorIndex = 40
.Pattern = xlSolid
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Font
.Name = "Times New Roman"
.Size = 10
.Font.Bold = True
End With
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
End Sub



--

HTH

RP
(remove nothere from the email address if mailing direct)
 
M

mully

Hi Gentlemen

Thanks for all the info managed to get

Managed to get both Duke & Bobs' working OK as there is different info Rich
wasn't feasible --- just one query the info at the moment is entering columns
& cells Z2/AA2 range for "ALTON" The question is if I had more info for
"ALTON" it would have to go into columns AB/AC is it possible for the macro
to search and find the first empty columns which would be AB/AC then do the
business of entering the data which would always be in sheet "(RPRA") range
"I2:J19)

Once again Thanks --- Have a Happy & Prosperous 2006

Cheers

Mully
 
B

Bob Phillips

You can fine the first empty column number with

iLastCol = Cells(2,Columns.Count).End(xlToLeft).Column

and use this like so (in my version)


FormatSheet Range("I2:J19"), Sheets("ALTON")
End Sub

Sub FormatSheet(Source As Range, Target As Worksheet)
Dim iLastCol As Long


iLastCol = Cells(2,Columns.Count).End(xlToLeft).Column
Sheets("RPRA").Source.Copy Target.Cells(2,iLastCol)
With Target




--

HTH

RP
(remove nothere from the email address if mailing direct)
 
M

mully

Hi Bob

Thanks for info will have a go tomorrow -- got visitors arriving shortly ---
will either of catch Chelsea???

Cheers

Mully
 
B

Bob Phillips

Fraid not, don't forget Chelsea can (will) buy more in January. Sorry state.

--

HTH

RP
(remove nothere from the email address if mailing direct)
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

help needed with borders 2
Micro to do borders question. 3
Macro: Insert Row above Totals 6
Auto Write Name and Merge across 0
VBA code question 1
Hlp! Adv Filter - Non-Contiguous rows don't copy 11
C++ OLE automation - how do I format the borders? 19
Border formatting row of cells 22

Top