Thread: Excel 2003 Macro
View Single Post
  #1   Report Post  
Posted to microsoft.public.excel.worksheet.functions
Tanisha Tanisha is offline
external usenet poster
  
Posts: 9
Default Excel 2003 Macro
CODE
Private Sub Auto_Open()
Application.OnKey "^+s", "Sort"
End Sub
Public Sub Sort()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim SortOrder As Variant
Dim Ndx As Long

For Each ws In Worksheets
ws.Visible = True
Next ws

Application.DisplayAlerts = False
If SheetExists("Spring '07", ActiveWorkbook) = True Then
Sheets("Spring '07").Select
ActiveWindow.SelectedSheets.Delete
Else
' sheet does not exist
End If

If SheetExists("Spring '08", ActiveWorkbook) = True Then
Sheets("Spring '08").Select
ActiveWindow.SelectedSheets.Delete
Else
End If

If SheetExists("Summer '07", ActiveWorkbook) = True Then
Sheets("Summer '07").Select
ActiveWindow.SelectedSheets.Delete
Else
End If

If SheetExists("Summer '08", ActiveWorkbook) = True Then
Sheets("Summer '08").Select
ActiveWindow.SelectedSheets.Delete
Else
End If

If SheetExists("Fall '07", ActiveWorkbook) = True Then
Sheets("Fall '07").Select
ActiveWindow.SelectedSheets.Delete
Else
End If

If SheetExists("Fall '08", ActiveWorkbook) = True Then
Sheets("Fall '08").Select
ActiveWindow.SelectedSheets.Delete
Else
End If

If SheetExists("Winter '07", ActiveWorkbook) = True Then
Sheets("Winter '07").Select
ActiveWindow.SelectedSheets.Delete
Else
End If

If SheetExists("Winter '08", ActiveWorkbook) = True Then
Sheets("Winter '08").Select
ActiveWindow.SelectedSheets.Delete
Else
End If

If SheetExists("Winter '09", ActiveWorkbook) = True Then
Sheets("Winter '09").Select
ActiveWindow.SelectedSheets.Delete
Else
End If

Application.DisplayAlerts = True

Set ws1 = Sheets("Solution Direct Tracking") '<<< Change
'Tip : Use a Dynamic range name,
http://www.contextures.com/xlNames01.html#Dynamic
'or a fixed range like Range("A1:H1200")
Set rng = ws1.Range("A1").CurrentRegion '<<< Change

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

With ws1
rng.Columns(10).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
'This example filter on the first column in the range (change this
if needed)
'You see that the last two columns of the worksheet are used to make
a Unique list
'and add the CriteriaRange.(you can't use this macro if you use the
columns)

Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row
.Range("IU1").Value = .Range("IV1").Value

For Each cell In .Range("IV2:IV" & Lrow)
.Range("IU2").Value = cell.Value
Set WSNew = Sheets.Add
On Error Resume Next
WSNew.Name = Left(cell.Value, Len(cell.Value) - 2) &
Format(Val(Right(cell.Value, 2)) + 1, "00")
If Err.Number 0 Then
MsgBox "Change the name of : " & WSNew.Name & " manually"
Err.Clear
End If
On Error GoTo 0
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=WSNew.Range("A1"), _
Unique:=False
WSNew.Columns.AutoFit
Next
.Columns("IU:IV").Clear
End With

With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With

SortOrder = Array("Solution Direct Tracking", "Spring '08", "Summer
'07", "Summer '08", "Fall '07", "Winter '07")
For Ndx = UBound(SortOrder) To LBound(SortOrder) Step -1

Next Ndx

Application.Run "Formating"

End Sub
Private Sub Auto_Close()
Application.OnKey "^+s"
End Sub
Function SheetExists(SheetName As String, _
Optional InWorkbook As Workbook) As Boolean
Dim WB As Workbook
If InWorkbook Is Nothing Then
Set WB = ActiveWorkbook
Else
Set WB = InWorkbook
End If
On Error Resume Next
SheetExists = CBool(Len((WB.Worksheets(SheetName).Name)))
End Function

Public Sub Formating()
Dim sourceRange As Range
Dim destrange As Range
Dim Lr As Long
Sheets("Solution Direct Tracking").Select
Range("A1").Select
Selection.AutoFilter
Selection.Sort Key1:=Range("D2"), Order1:=xlAscending,
Key2:=Range("C2") _
, Order2:=xlAscending, Key3:=Range("F2"), Order3:=xlAscending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom


Sheets("Spring '08").Select
Cells.Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Interior.ColorIndex = xlNone
Rows("1:1").Select
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
End With
Range("A2").Select
Cells.Replace What:="Sold", Replacement:="Right of First Refusal",
Lookat _
:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
Range("E2").Select
Selection.Columns.AutoFit
Selection.Sort Key1:=Range("F2"), Order1:=xlAscending, Key2:=Range("I2") _
, Order2:=xlAscending, Key3:=Range("C2"), Order3:=xlAscending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom



Sheets().Select
Cells.Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Interior.ColorIndex = xlNone
Rows("1:1").Select
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
End With
Range("A2").Select
Cells.Replace What:="Sold", Replacement:="Right of First Refusal",
Lookat _
:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
Range("E2").Select
Selection.Columns.AutoFit


Sheets("Summer '08").Select
Cells.Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Interior.ColorIndex = xlNone
Rows("1:1").Select
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
End With
Range("A2").Select
Cells.Replace What:="Sold", Replacement:="Right of First Refusal",
Lookat _
:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
Range("E2").Select
Selection.Columns.AutoFit
Selection.Sort Key1:=Range("F2"), Order1:=xlAscending, Key2:=Range("I2") _
, Order2:=xlAscending, Key3:=Range("C2"), Order3:=xlAscending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Sheets().Select
Cells.Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Interior.ColorIndex = xlNone
Rows("1:1").Select
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
End With
Range("A2").Select
Cells.Replace What:="Sold", Replacement:="Right of First Refusal",
Lookat _
:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
Range("E2").Select
Selection.Columns.AutoFit


' Sheets("Fall '08").Select
' Cells.Select
' With Selection.Font
' .Name = "Arial"
' .FontStyle = "Regular"
' .Size = 10
' .Strikethrough = False
' .Superscript = False
'.Subscript = False
' .OutlineFont = False
' .Shadow = False
' .Underline = xlUnderlineStyleNone
' .ColorIndex = xlAutomatic
'End With
' Selection.Interior.ColorIndex = xlNone
' Rows("1:1").Select
' With Selection.Interior
' .ColorIndex = 34
' .Pattern = xlSolid
' End With
' Range("A2").Select
' Cells.Replace What:="Sold", Replacement:="Right of First Refusal",
Lookat _
' :=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
'' Range("E2").Select
' Selection.Columns.AutoFit
' Selection.Sort Key1:=Range("F2"), Order1:=xlAscending,
Key2:=Range("I2") _
' , Order2:=xlAscending, Key3:=Range("C2"), Order3:=xlAscending,
Header:= _
' xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom


Sheets("Winter '07").Select
Cells.Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Interior.ColorIndex = xlNone
Rows("1:1").Select
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
End With
Range("A2").Select
Cells.Replace What:="Sold", Replacement:="Right of First Refusal",
Lookat _
:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
Range("E2").Select
Selection.Columns.AutoFit
Selection.Sort Key1:=Range("F2"), Order1:=xlAscending, Key2:=Range("I2") _
, Order2:=xlAscending, Key3:=Range("C2"), Order3:=xlAscending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

' Sheets("Winter '09").Select
' Cells.Select
' With Selection.Font
' .Name = "Arial"
' .FontStyle = "Regular"
' .Size = 10
' .Strikethrough = False
' .Superscript = False
' .Subscript = False
' .OutlineFont = False
' .Shadow = False
' .Underline = xlUnderlineStyleNone
' .ColorIndex = xlAutomatic
' End With
' Selection.Interior.ColorIndex = xlNone
' Rows("1:1").Select
' With Selection.Interior
' .ColorIndex = 34
' .Pattern = xlSolid
' End With
' Range("A2").Select
' Cells.Replace What:="Sold", Replacement:="Right of First Refusal",
Lookat _
' :=xlWhole, SearchOrder:=xlByRows, MatchCase:=False
' 'Range("E2").Select
'Selection.Columns.AutoFit
'Selection.Sort Key1:=Range("F2"), Order1:=xlAscending, Key2:=Range("I2") _
' , Order2:=xlAscending, Key3:=Range("C2"), Order3:=xlAscending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

End Sub





Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function Lastcol(sh As Worksheet)
On Error Resume Next
Lastcol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function



Private Sub Workbook_BeforeClose(Cancel As Boolean)
If ThisWorkbook.ReadOnly = False Then
Application.DisplayAlerts = False
Application.Run "Sort"
Sheets("Solution Direct Tracking").Select
ThisWorkbook.Save

Else
End If
Application.DisplyAlerts = True
End Sub

End Sub










"Gord Dibben" wrote:

Post the code from your macro.


Gord Dibben MS Excel MVP

On Tue, 1 Aug 2006 12:13:02 -0700, Tanisha
wrote:

I tried to find my mistake...so I guess I'll keep looking.

"Tanisha" wrote:

I'm running a macro that has 6 Sheets in the workbook. After the macro runs
(sort and formatting) the order of my sheets get scrambled. What can I add to
my macro to put my sheets back in order?


Reply With QuoteReply With Quote