Excel Macros |
 |
 |
Download
file with the following
macros:
- Rename sheet tabs fast
- Rename custom button that you have added
- Change Absolutes to Relative reference or Relative to Absolutes
- Find a employee name based on a number from a list and replace number with name
- Print reports with a dialog box using drop down list
Other macros
|
|
|
Remove
spaces
from a column
Just copy from "Sub TrimALL()" down to "End Sub". Place in the
personal workbook.
Sub TrimALL()
Do Until ActiveCell = ""
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim cell As Range
'Also Treat CHR 0160, as a space (CHR 032)
Selection.Replace What:=Chr(160), Replacement:=Chr(32), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
'Trim in Excel removes extra internal spaces, VBA does not
On Error Resume Next 'in case no text cells in selection
For Each cell In Intersect(Selection, _
Selection.SpecialCells(xlConstants, xlTextValues))
cell.Value = Application.Trim(cell.Value)
Next cell
On Error GoTo 0
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
ActiveCell.Offset(1, 0).Range("A1").Select
Loop
End Sub
Change
Upper Case text to proper case
Sub Proper_Case()
'place active cell (cursor) at the top of the column that needs
correcting
'the next line selects the column
Range(Selection, Selection.End(xlDown)).Select
'The next line setup the active cell in the selected area as an
individual item.
Set C = ActiveCell
' X in the for each loop is really the C or the active cell
' so the macro will follow the selected range to the end
' Loop to cycle through each cell in the specified range.
For Each x In Selection
' There is not a Proper function in Visual Basic for Applications.
' So, you must use the worksheet function in the following form:
x.Value = Application.Proper(x.Value)
Next
End Sub
Remove Links from Spreadsheet
Sub removelinkCells()
'
' removelinkCells Macro
' Macro recorded 4/13/2004 by Jesse Braswell '
'
Selection.CurrentRegion.Select
Selection.Hyperlinks.Delete
End Sub
Find a dup in my list
Place two columns next to each other
that you would like to find a duplicate.
Column A - should be blank
Column B - is the new list of values to
search (find dup in)
Column C - is the list of items
you already had
|
A |
B |
C |
|
|
New Account # |
Old Account # |
|
|
12351 |
12345 |
|
|
12352 |
12346 |
|
|
12346 |
12347 |
|
|
12342 |
12348 |
|
|
12357 |
12349 |
|
|
12349 |
|
Place the active cell in C2 then run the macro
Sub Replacewithdup()
Dim holdplace ' set variables
Dim company
Dim secondcompany
Dim topoflist
ActiveCell.Offset(0, -1).Range("a1").Select
'move over one column and get
' holder for
' beginning of list to be checked
topoflist = Selection.Address
'remember the holder address
ActiveCell.Offset(0, 1).Range("a1").Select
'move back to the right
' to be in the correct starting
' place for search to begin
Start:
Do Until ActiveCell = ""
'Stop when the bottom of list
' is reached
holdplace = Selection.Address
'remember cell address -
' where we started
companyorg = ActiveCell.FormulaR1C1
'remember name of company
' to search for
Range(topoflist).Select
'Start at the top of column
' that needs to be searched
Do Until ActiveCell = ""
'start search for match
If companyorg = ActiveCell.FormulaR1C1 Then
'check for match
ActiveCell.Offset(0, -1).Range("a1").Select
'if it is a match move left one
' cell
ActiveCell.FormulaR1C1 = "Dup"
'place 500 in the blank
cell
Range(holdplace).Select
'go back to last company
'that was checked
ActiveCell.Offset(1, 0).Range("a1").Select
'drop down one row to be in
' the correct cell to start a
' new search for the next
' company
GoTo Start
'Go back to the start of the
' routine to begin a new search
Else
'If a match is not found
' move down to check the next
' company name in the list
ActiveCell.Offset(1, 0).Range("a1").Select
'move down to check the next
' company name in the list
End If
'end if and start loop again
Loop
'go through loop again
Range(holdplace).Select
'go to last company name that
' was checked
ActiveCell.Offset(1, 0).Range("a1").Select
'Then move down one to start
' the process again
Loop
' Start the loop over again
End Sub
' end the routine
Paint Rows Green
Sub ColorRowsGreen()
Dim i As Integer
Dim iNumberOfRows As Integer
'find out how many rows there are
iNumberOfRows = 0
i = 1
While Sheets("sheet1").Cells(i, 1).Value <> ""
iNumberOfRows = iNumberOfRows + 1
i = i + 1
Wend
'MsgBox "There are " & CStr(iNumberOfRows) & " records.", vbInformation
+ vbOKOnly, "Informaton to Users"
'first reset previous colors to white
'color every other row range
For i = 2 To iNumberOfRows + 1
Sheets("sheet1").Range(Cells(i, 1), Cells(i, 24)).Interior.ColorIndex =
2
Next i
'color every other row range as light green
For i = 2 To iNumberOfRows + 1 Step 2
Sheets("sheet1").Range(Cells(i, 1), Cells(i, 24)).Interior.ColorIndex =
35
Next i
End Sub
Add
columns together
Sub AddColumnstogether()
'Add text from column B to the text already in column A
'then places the word moved in the B column
Dim intRow As Integer, intRowL As Integer
Application.ScreenUpdating = False
intRowL = Cells(Rows.Count, 1).End(xlUp).Row
For intRow = 1 To intRowL
Cells(intRow, 1) = Cells(intRow, 1) & " " & Cells(intRow, 2)
Next intRow
Range(Cells(1, 2), Cells(intRowL, 2)).Value = "Moved"
Columns.AutoFit
Application.ScreenUpdating = True
End Sub
Save all my sheets
Sub sheettabs_save()
'Place one sheet at the far right (last sheet) and name it sheet1
'Click on first sheet in your workbook and run macro
Do While ActiveSheet.Name <> "Sheet1"
dsName = ActiveSheet.Name
Mydate = Format(Date, "yyyymmdd")
ActiveWorkbook.Windows(1).SelectedSheets.Copy
dName = "C:\workbooks\" & dsName & " " & Mydate & ".xls"
ActiveWorkbook.SaveAs dName
ActiveWorkbook.Close savechanges:=False
Application.DisplayAlerts = False
ActiveWorkbook.Windows(1).SelectedSheets.Delete
Application.DisplayAlerts = True
Loop
End Sub
| 
