Excel vba
Excel VBA Code:
ListToTabs |
Sub ListToTabs()
'Copies agents over to correct Sup Sheet
Dim test As String
With Ws_Audit
Ws_Audit.Select
For Each Tcell In Ws_Audit.Range("A2", Range("A" & Rows.Count).End(xlUp))
test = Tcell.Offset(0, 2).Value
Tcell.EntireRow.Copy
Sheets("" & test & "").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
Next
End With
End Sub
Sub AddBlankRowtoList() |
Sub AddBlankRowtoList()
Dim cell As Range
Dim ColNum As String
ColNum = InputBox("What Column?", "Column")
For I = Cells(Rows.Count, ColNum).End(xlUp).Row To 2 Step -1
If Not Cells(I, ColNum).Value = "" Then
Cells(I, ColNum).EntireRow.Insert Shift:=xlUp
End If
Next
End Sub
Sub FiscalDates() |
Sub FiscalDates()
Dim MyworkSheet As Worksheet
Dim MainBook, SecondBook As Workbook
Set MyworkSheet = ActiveSheet
Set MainBook = ActiveWorkbook
Sheets.Add After:=Sheets(Sheets.Count)
Workbooks.Open Filename:= _
"\\ent.core.medtronic.com\mit-sat01\SAT Public\WFM\Tyger\FiscalDatesVlookup.xlsx"
Windows("FiscalDatesVlookup.xlsx").Activate
Set SecondBook = ThisWorkbook
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
MainBook.Activate
ActiveSheet.Paste
ActiveSheet.Name = "FiscalLookupTempSheet"
Windows("FiscalDatesVlookup.xlsx").Activate
Application.DisplayAlerts = False
ActiveWindow.Close
Application.DisplayAlerts = True
MainBook.Activate
MyworkSheet.Select
Set MyYearColumn = Application.InputBox("Select a Starting Cell for Year", "Choose Cell", Type:=8)
YearR = MyYearColumn.Row
YearC = MyYearColumn.Column
MyworkSheet.Select
Set MyQuarterColumn = Application.InputBox("Select a Starting Cell for Quarter", "Choose Cell", Type:=8)
QuarterR = MyQuarterColumn.Row
QuarterC = MyQuarterColumn.Column
MyworkSheet.Select
Set MyMonthColumn = Application.InputBox("Select a Starting Cell for Month", "Choose Cell", Type:=8)
MonthR = MyMonthColumn.Row
MonthC = MyMonthColumn.Column
MyworkSheet.Select
Set MyWeekColumn = Application.InputBox("Select a Starting Cell for Week", "Choose Cell", Type:=8)
WeekR = MyWeekColumn.Row
WeekC = MyWeekColumn.Column
MyworkSheet.Select
MyCellsStartingRow = WeekR
MyworkSheet.Select
Set LookUpValue = Application.InputBox("Select a LookUp Value", "Choose Cell", Type:=8)
LookUpValueR = LookUpValue.Row
LookUpValueC = LookUpValue.Column
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
LastRow = Cells(Rows.Count, LookUpValueC).End(xlUp).Row
FirstRow = YearR
MyStartTime = Now
For I = FirstRow To LastRow
'TimePassing = Now - MyStartTime
Application.StatusBar = I & " out of " & LastRow & " " '& Format(TimePassing, "hh:MM:SS")
Cells(MyCellsStartingRow, YearC).Value = Application.WorksheetFunction.VLookup(Cells(LookUpValueR, LookUpValueC), Sheets("FiscalLookupTempSheet").Range("A:Q"), 5, False)
Cells(MyCellsStartingRow, QuarterC).Value = Application.WorksheetFunction.VLookup(Cells(LookUpValueR, LookUpValueC), Sheets("FiscalLookupTempSheet").Range("A:Q"), 6, False)
Cells(MyCellsStartingRow, MonthC).Value = Application.WorksheetFunction.VLookup(Cells(LookUpValueR, LookUpValueC), Sheets("FiscalLookupTempSheet").Range("A:Q"), 7, False)
Cells(MyCellsStartingRow, WeekC).Value = Application.WorksheetFunction.VLookup(Cells(LookUpValueR, LookUpValueC), Sheets("FiscalLookupTempSheet").Range("A:Q"), 8, False)
YearR = YearR + 1
QuarterR = QuarterR + 1
MonthR = MonthR + 1
WeekR = WeekR + 1
LookUpValueR = LookUpValueR + 1
MyCellsStartingRow = MyCellsStartingRow + 1
Next
Cells(1, YearC).Value = "Year"
Cells(1, QuarterC).Value = "Quarter"
Cells(1, MonthC).Value = "Month"
Cells(1, WeekC).Value = "Week"
Application.DisplayAlerts = False
Sheets("FiscalLookupTempSheet").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = ""
End Sub
Sub DateandTimeBreaker() |
Sub DateandTimeBreaker()
Set MyDate = Application.InputBox("Select a Starting Cell for Dates", "Choose Cell", Type:=8)
DateRow = MyDate.Row
DateCol = MyDate.Column
Set MyTime = Application.InputBox("Select a Starting Cell for Time", "Choose Cell", Type:=8)
TimeRow = MyTime.Row
TimeCol = MyTime.Column
Set LookUpValue = Application.InputBox("Select a LookUpCell", "Choose Cell", Type:=8)
LookupValueRow = LookUpValue.Row
LookUpValueCol = LookUpValue.Column
If TimeRow = 1 Then
MsgBox ("Please Add Header Row and Try Again")
Exit Sub
End If
LastRow = Cells(Rows.Count, LookUpValueCol).End(xlUp).Row
FirstRow = LookupValueRow
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For I = FirstRow To LastRow
Cells(DateRow, DateCol).Value = DateValue(Application.WorksheetFunction.Text(Cells(LookupValueRow, LookUpValueCol), "MM/DD/YYYY"))
Cells(TimeRow, TimeCol).Value = TimeValue(Application.WorksheetFunction.Text(Cells(LookupValueRow, LookUpValueCol), "HH:MM AM/PM"))
DateRow = DateRow + 1
TimeRow = TimeRow + 1
LookupValueRow = LookupValueRow + 1
Application.StatusBar = DateRow & " of " & LastRow
Next
Cells(1, DateCol).Value = "Date"
Cells(1, TimeCol).Value = "Time"
Application.StatusBar = ""
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub FindandHighlight() |
Sub FindandHighlight()
Dim I, t As Integer
Dim MyCol, MySearch As String
MyCol = InputBox("What Column", "Column")
MySearch = InputBox("Search Term:", "Search")
For I = Cells(Rows.Count, MyCol).End(xlUp).Row To 2 Step -1
t = InStr(1, Cells(I, MyCol).Value, MySearch, vbTextCompare)
If t > 0 Then
Cells(I, MyCol).Interior.Color = vbYellow
End If
Next
End Sub
Sub Tenure() |
Sub Tenure()
ReturnType = InputBox("What format? YYYY or M or D ", "Y for Year, M for Month , D for Day")
OrgDate = Application.InputBox("Select a range", "Choose Range", Type:=8)
MyDate = DateDiff(ReturnType, OrgDate, Now())
MsgBox (MyDate)
End Sub
Function SwtichName(cell As Range) |
Function SwtichName(cell As Range)
'Function Needed to Split Name
Name = Split(Replace(cell.Text, Chr(160), ""), ",")
SwitchName = Trim(Name(1)) & " " & Trim(Name(0))
End Function
Sub SendSupsEmails() |
Sub SendSupsEmails()
Dim rng As Range
Dim examples As Range
Dim OutApp As Object
Dim OutMail As Object
Dim strBody As String
Dim strBody1 As String
Const olImportanceHigh = 2
Set rng = Nothing
On Error Resume Next
Call PrepEmailsheets
strBody = "This Escalation is for " & "
"
strBody1 = "We are doing our Bi-Weekly Aux 2 Audit. " & "
" & "
" & _
"Agents listed above have exceeded that threshold for date Range : " & _
wsMain.Range("Date_Start").Value & " - " & _
wsMain.Range("Date_End").Value & "
" & "
" & _
"Agents are escalated 2.50% of their staffed time: " & "
" & "
" & _
"For Example: "
Set OutApp = CreateObject("Outlook.Application")
wsSupList.Select
Set examples = wsMain.Range("H2:I7")
For Each cell In wsSupList.Range("A2", Range("A" & Rows.Count).End(xlUp))
Set rng = Sheets("" & cell.Value & "").UsedRange
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.SentOnBehalfOfName = "Care<Care.e@company.com>"
.To = cell.Value
.CC = cell.Offset(0, 1).Value
.BCC = ""
.Subject = "Email Subject"
.Importance = olImportanceHigh
.HTMLBody = strBody & RangetoHTML(rng) & "
" & strBody1 & "
" & RangetoHTML(examples)
.Display 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
MSG1 = MsgBox("Do you wish to conintue?", vbYesNo, "Sending Emails")
If MSG1 = vbYes Then
' nothing
Else
Exit Sub
End If
Next cell
Call Hidesups
Set OutMail = Nothing
Set OutApp = Nothing
wsEventLog.Select
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Sub MoveHighlighted() |
Sub MoveHighlighted()
Dim cell As Range
For Each cell In Sheet6.Range("A2", Range("A" & Rows.Count).End(xlUp))
If cell.Interior.Color = vbRed Then
cell.Copy
Sheet6.Range("L" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
Next
For Each cell In Sheet6.Range("G2", Range("G" & Rows.Count).End(xlUp))
If cell.Interior.Color = vbRed Then
cell.Copy
Sheet6.Range("L" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
Next
End Sub
Sub RemoveRowIFString() |
Sub RemoveRowIFString()
Dim I As Integer
For I = Sheet9.Cells(Rows.Count, "F").End(xlUp).Row To 2 Step -1
t = InStr(1, Cells(I, "F").Value, "Training", vbTextCompare)
If InStr(1, Cells(I, "F").Value, "Training", vbTextCompare) > 0 Then
Sheet9.Cells(I, "F").EntireRow.Delete
End If
Next
End Sub
Sub DeleteObj() |
Sub DeleteObj()
Application.StatusBar = " Deleteing Objects"
Dim Obj As Object
For Each Obj In ActiveSheet.Shapes ' Deletes all object on selected page
Obj.Delete
Next
Application.StatusBar = ""
End Sub
Shade Every Other Row |
Sub ShadeEveryOtherRow()
Dim Counter As Integer
Dim rng As Range
On Error GoTo ErrHandler 'Exits if Error
Set rng = Application.InputBox("Select a range", "Choose Range", Type:=8) 'Pop Up To Select Range
'Highlights Every Other Row Grey
For Counter = 1 To rng.Rows.Count
'If the row is an odd number it highlights it Grey
If Counter Mod 2 = 1 Then
With rng.Rows(Counter).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
End If
Next
'Adds Borders
rng.Borders(xlEdgeLeft).LineStyle = xlContinuous
rng.Borders(xlEdgeLeft).Weight = xlThin
rng.Borders(xlEdgeTop).LineStyle = xlContinuous
rng.Borders(xlEdgeTop).Weight = xlThin
rng.Borders(xlEdgeBottom).LineStyle = xlContinuous
rng.Borders(xlEdgeBottom).Weight = xlThin
rng.Borders(xlEdgeRight).LineStyle = xlContinuous
rng.Borders(xlEdgeRight).Weight = xlThin
rng.Borders(xlInsideVertical).LineStyle = xlContinuous
rng.Borders(xlInsideVertical).Weight = xlThin
rng.Borders(xlInsideHorizontal).LineStyle = xlContinuous
rng.Borders(xlInsideHorizontal).Weight = xlThin
ErrHandler: Exit Sub
End Sub
5 digit Number Extract |
Function FiveDigitNo(s As String)
With CreateObject("vbscript.regexp")
.Pattern = "\b\d{5}\b"
If .Test(s) Then FiveDigitNo = .Execute(s)(0)
End With
End Function
BuildandRemoveList |
Sub BuildandRemove()
Set List = CreateObject("Scripting.Dictionary")
'Adds Agent Id's From Hierachy To List
With wsHierarchy
wsHierarchy.Select
For Each rng In wsHierarchy.Range("B1", Range("B" & Rows.Count).End(xlUp))
If Not List.Exists(rng.Value) Then
List.Add rng.Value, Nothing
End If
Next
End With
'Checks Agents in Audit vs List and Removes if not in list
With wsAudit
wsAudit.Select
For rw = wsAudit.Cells(Rows.Count, "B").End(xlUp).Row To 4 Step -1
If Not List.Exists(.Cells(rw, "B").Value) Then
.Rows(rw).Delete
End If
Next
End With
Set List = Nothing
End Sub