This routine provides a password to unprotect your worksheet. However, it may not give you the original password that was used.
Open the workbook that has the protected sheet in it. Hit Alt+F11 to view the Visual Basic Editor. Hit Insert-Module and paste this code into the right-hand code window:
Sub PasswordBreaker
()
'Author unknown but submitted by brettdj of www.experts-exchange.com
Dim i
As Integer, j
As Integer, k
As Integer
Dim l
As Integer, m
As Integer, n
As Integer
Dim i1
As Integer, i2
As Integer, i3
As Integer
Dim i4
As Integer, i5
As Integer, i6
As Integer
On Error Resume Next
For i =
65 To 66:
For j =
65 To 66:
For k =
65 To 66
For l =
65 To 66:
For m =
65 To 66:
For i1 =
65 To 66
For i2 =
65 To 66:
For i3 =
65 To 66:
For i4 =
65 To 66
For i5 =
65 To 66:
For i6 =
65 To 66:
For n =
32 To 126
ActiveSheet.
Unprotect Chr(i
) &
Chr(j
) &
Chr(k
) & _
Chr(l
) &
Chr(m
) &
Chr(i1
) &
Chr(i2
) &
Chr(i3
) & _
Chr(i4
) &
Chr(i5
) &
Chr(i6
) &
Chr(n
)
If ActiveSheet.
ProtectContents =
False Then
MsgBox "One usable password is " &
Chr(i
) &
Chr(j
) & _
Chr(k
) &
Chr(l
) &
Chr(m
) &
Chr(i1
) &
Chr(i2
) & _
Chr(i3
) &
Chr(i4
) &
Chr(i5
) &
Chr(i6
) &
Chr(n
)
ActiveWorkbook.
Sheets(1).
Select
Range
("a1").
FormulaR1C1 =
Chr(i
) &
Chr(j
) & _
Chr(k
) &
Chr(l
) &
Chr(m
) &
Chr(i1
) &
Chr(i2
) & _
Chr(i3
) &
Chr(i4
) &
Chr(i5
) &
Chr(i6
) &
Chr(n
)
Exit Sub
End If
Next:
Next:
Next:
Next:
Next:
Next
Next:
Next:
Next:
Next:
Next:
Next
End Sub
Close the VB Editor window. Navigate to the worksheet you want to unprotect. Hit Tools-Macro-Macros and double-click PasswordBreaker in the list.
Source: http://www.theofficeexperts.com/VBASamples/Excel02.htm
OCTOBER 22ND, 2009
By ADMIN
Option Explicit
Sub ExcelDiet()
Dim j As Long
Dim k As Long
Dim LastRow As Long
Dim LastCol As Long
Dim ColFormula As Range
Dim RowFormula As Range
Dim ColValue As Range
Dim RowValue As Range
Dim Shp As Shape
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
For Each ws In Worksheets
With ws
'Find the last used cell with a formula and value
'Search by Columns and Rows
On Error Resume Next
Set ColFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
Set ColValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
Set RowFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
Set RowValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
On Error Goto 0
'Determine the last column
If ColFormula Is Nothing Then
LastCol = 0
Else
LastCol = ColFormula.Column
End If
If Not ColValue Is Nothing Then
LastCol = Application.WorksheetFunction.Max(LastCol, ColValue.Column)
End If
'Determine the last row
If RowFormula Is Nothing Then
LastRow = 0
Else
LastRow = RowFormula.Row
End If
If Not RowValue Is Nothing Then
LastRow = Application.WorksheetFunction.Max(LastRow, RowValue.Row)
End If
'Determine if any shapes are beyond the last row and last column
For Each Shp In .Shapes
j = 0
k = 0
On Error Resume Next
j = Shp.TopLeftCell.Row
k = Shp.TopLeftCell.Column
On Error Goto 0
If j> 0 And k> 0 Then
Do Until .Cells(j, k).Top> Shp.Top + Shp.Height
j = j + 1
Loop
If j> LastRow Then
LastRow = j
End If
Do Until .Cells(j, k).Left> Shp.Left + Shp.Width
k = k + 1
Loop
If k> LastCol Then
LastCol = k
End If
End If
Next
.Range(Cells(1, LastCol + 1).Address & ":IV65536").Delete
.Range(Cells(LastRow + 1, 1).Address & ":IV65536").Delete
End With
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Great article with screenshots.. Doesnt get any clearer than this:
Spreadsheet123.com
Too bad it doesnt work for rows adding up to 0 in the pivot (say source has a -10 and 10, so the pivot shows 0, the trick above doesn't work for that)..
Set font to Wingdings, and use ALT+0252..
So simple, but took me a while to get it 
Sub Sort_Active_Book()
Dim i As Integer
Dim j As Integer
Dim iAnswer As VbMsgBoxResult
'
' Prompt the user as which direction they wish to
' sort the worksheets.
'
iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) _
& "Clicking No will sort in Descending Order", _
vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")
For i = 1 To Sheets.Count
For j = 1 To Sheets.Count - 1
'
' If the answer is Yes, then sort in ascending order.
'
If iAnswer = vbYes Then
If UCase$(Sheets(j).Name)> UCase$(Sheets(j + 1).Name) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
'
' If the answer is No, then sort in descending order.
'
ElseIf iAnswer = vbNo Then
If UCase$(Sheets(j).Name) <UCase$(Sheets(j + 1).Name) Then
Sheets(j).Move After:=Sheets(j + 1)
End If
End If
Next j
Next i
End Sub
If the number is in A2 just use this formula
To round to the NEAREST 500: (eg. 524 rounds to 500)
=ROUND(A2/500,0)*500
To round to the NEXT HIGHEST 500: (eg. 524 rounds to 1000)
=CEILING(A2,500)
Option Explicit
Sub RefreshAllPivots()
Dim ws As Worksheet
Dim pt As PivotTable
On Error Resume Next
For Each ws In ActiveWorkbook.Worksheets
For Each pt In ws.PivotTables
pt.RefreshTable
Next
Next
End Sub
Select a range and run the macro. If no range is selected, the entire sheet is processed.
Sub UpperCase
()
Dim cell
As Excel.
Range
For Each cell In Selection.SpecialCells(xlTextValues, 2)
cell.Value = Ucase$(cell.Value)
Next cell
End Sub
Sub LowerCase
()
Dim cell
As Excel.
Range
For Each cell In Selection.SpecialCells(xlTextValues, 2)
cell.Value = Lcase$(cell.Value)
Next cell
End Sub
Source: http://www.codeforexcelandoutlook.com/blog/
To use this macro, run the FindCircRefs macro from the Microsoft Excel worksheet for which you want to find circular references. A new sheet is added to the active workbook, listing the cell addresses of circular references in column A and the formula at that address in column B. If no circular references are found, the new sheet is empty.
Sub FindCircRefs
()
' Get source information.
sourcesheet = ActiveSheet.
Name
Sheets.
Add
' Get destination information.
destsheet = ActiveSheet.
Name
destrange = ActiveCell.
Address
' Return to source.
Worksheets
(sourcesheet
).
Activate
rowcount =
0
' Trap for error in "result", indicating no circular reference.
On Error GoTo notcircular
' Loop through every used cell in source.
For Each Item In ActiveSheet.UsedRange
' Check to see if cell contains a formula.
If Left(Item.Formula, 1) = "=" Then
' If cell intersects with precedents, cell has circular
' reference.
result = Intersect(ActiveSheet.Range(Item.Address), _
ActiveSheet.Range(Item.Precedents.Address))
Worksheets(destsheet).Range(destrange).Offset(rowcount, _
0).Value = Item.Address(False, False)
Worksheets(destsheet).Range(destrange).Offset(rowcount, _
1).Value = "'" & Item.Formula
rowcount = rowcount + 1
' Skip to here if not circular.
skipitem:
End If
Next
Exit Sub
' If error in "result", go here.
notcircular:
' Skip cells that do not contain circular references.
Resume skipitem
End Sub
APRIL 29TH, 2009
By ADMIN
When you are doing a lot of reporting, often you have the same report for several
products, LOB's, Business Units etc.
Now most of the time these reports exist and are maintained separate, which
is a nightmare ofcourse. Much easier would be to build one report, and use a macro
to create separate output files.
This macro does that for you. What do you need:
1. A report that changes data by changing a cell value.
In this example cell A1 on the report in sheet1 is the trigger for the data in the report
(so when A1 is "LOB1" the report shows LOB1 data, change it to "LOB2" your report
shows LOB2 data..)
2. A List with possible values for your report
Make a list with LOB1,LOB2,LOB3,LOB4 etc on Sheet2, and name the first value
of this list ReportStart.
This macro will start at the first value of your list, and work it's way down untill
it encounters a blank cell (end of your list)
Sub CREATE_XLS_FILES
()
'============================================================
'SOME SETTINGS
'============================================================
Dim ReportStart As String
Dim TargetWB As Workbook
Set TargetWB = ActiveWorkbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.GoTo Reference:="ReportStart"
Row = ActiveCell.Row
'============================================================
'WORK THROUGH ALL LOB's
'============================================================
Sheets("Sheet1").Select
While ActiveSheet.Cells(Row, 1).Value <> ""
Title = ActiveSheet.Cells(Row, 1).Value
'Change the trigger of the report, so all data is for the right LOB
Sheets("Sheet1").Range("A1").Value = Title
'Move the report to a new workbook
Sheets("Sheet1").Select
Sheets("Sheet1").Activate
Sheets("Sheet1").Copy
'Copy / Paste values to remove any annoying links
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("A1").Select
'save the new file. This will output as O:\TEMP\Report for LOB1.xls etc
ActiveWorkbook.SaveAs Filename:= _
"O:\TEMP\Report for " & Title & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
'close the new workbook
ActiveWorkbook.Close
'return to the original workbook
TargetWB.Activate
Sheets("Sheet1").Select
'and repeat it all for the next LOB in your list
Row = Row + 1
Wend
Application.ScreenUpdating = True
Application.DisplayAlerts = False
End Sub
