Sub Saveworksheet()
'
' Saveworksheet Macro
' ActiveSheet.Select
Dim FName As String
Dim FPath As String
FPath = "E:"
FName = ActiveSheet.Range("K3").Text
Sheet1.Copy
ThisWorkbook.SaveAs Filename:=FPath & "\" & FName
End SubcMSBPrgrs.Dsply "MyProcess", i With cASBPrgrs
.MainProcess = "xxxxx" ' Names the main process of which the progress is displayed
.MaxMsgLen = 150 ' Limits the lenght of the message which is adjusted intelligently when exeeded
.SubProcessesMax = 5 ' Limits the number of displayed sub-processes by dropping olders
.MsecToNextDsply = 200 ' Avoids a possible performance loss caused by DoEvents, which is used to ensure a frequent message update
End WithSub Workbook_Open()
For Each cell In Sheets("HW").Range("H2:H9")
If cell.Value = "YES" And cell.Offset(0, -2).Value = "No" Then
MsgBox cell.Offset(0, -7).Value & " HW is due in today"
ElseIf cell.Value = "OVERDUE" Then
MsgBox cell.Offset(0, -7).Value & " HW is OVERDUE"
End If
Next
End SubSub UpdatecampaignId()
Dim DR As Long
Dim Cell As Range
Dim Dict As Object
Dim Key As String
Dim Item As Variant
Dim rng As Range
Dim Wks As Worksheet
Set rng = Rows(1).Find("campaignId")
If Not rng Is Nothing Then
DR = rng.Column
Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTextCompare
Set Wks = Worksheets("campaignId")
Set rng = Wks.Range("A1").CurrentRegion
Set rng = Intersect(rng, rng.Offset(1, 0))
For Each Cell In rng.Columns(1).Cells
Key = Trim(Cell)
Item = Cell.Offset(0, 1)
If Key <> "" Then
If Not Dict.exists(Key) Then Dict.Add Key, Item
End If
Next Cell
Set Wks = Worksheets("Copied Sheet")
Set rng = Wks.Range("A1").CurrentRegion
Set rng = Intersect(rng, rng.Offset(1, 0).Columns(DR))
For Each Cell In rng
Key = Trim(Cell)
If Dict.exists(Key) Then Cell = Dict(Key): Cell.Interior.ColorIndex = 6
Next Cell
End If
End SubSub FindCopyAll_Alt()
'
' FindCopyAll_Alt Macro
''I am using row one for labels so my first usable row is row 2
pos = 2
'
'I want to delete the "Search Results" sheet if it exists, So I am going to force an error
On Error GoTo NewSheet
'
'This blocks the message "Deleting Sheet Will Lose Data"
Application.DisplayAlerts = False
'
'This selects the results sheet, if it does not exist then we will go to NewSheet
Sheets("Search Results").Select
'
'This Deletes the Results Sheet
ActiveSheet.Delete
'
'This re-enables our error messages
Application.DisplayAlerts = True
'
'Create the Results Sheet
NewSheet:
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "Search Results"
ActiveSheet.Move Before:=Sheets(1)
'What Text do you want to search for?
MyStr = InputBox("Enter Text to Find", "Find Text Macro", "select", 100, 100)
'
'These are my Labels
Range("E1").Value = "Recommended Shortcuts:"
Range("F2").Value = "CTRL + SHIFT + V"
Range("F3").Value = "CTRL + SHIFT + C"
Range("F4").Value = "CTRL + SHIFT + X"
Range("F5").Value = "CTRL + SHIFT + Z"
Range("H3").Value = "_"
Range("H4").Value = ",_"
Range("H5").Value = ".__"
Range("I2").Value = "(Compile A1 List ONLY)"
Range("I3").Value = "(Compile A1 List and SPACE)"
Range("I4").Value = "(Compile A1 List, COMA, SPACE) "
Range("I5").Value = "(Compile A1 List, PERIOD, SPACE, SPACE)"
Range("B1").Value = "Rand"
'
'This resets our normal error routines
On Error GoTo 0
'
'Quit if search text is empty
If MyStr = "" Then Exit Sub
'
'Search for the Search String in each workbook except the results sheet
For Each ws In Sheets
'
If ws.Name = "Search Results" Then GoTo Skip
If ws.Name = "Srch" Then GoTo Skip
If ws.Name = "Rand" Then GoTo Skip
'
MyName = ws.Name
'
MyString = ""
'
With ws.Cells
Set rngFind = .Find(MyStr, .Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole)
If Not rngFind Is Nothing Then
strFirstAddress = rngFind.Address
'
Do
MyString = MyString & MyName & "!" & rngFind.Address & ", "
Set rngFind = .FindNext(rngFind)
Loop While Not rngFind Is Nothing And rngFind.Address <> strFirstAddress
End If
End With
'
'If Match Found then store data in Column A of results sheet
If MyString <> "" Then
'
'Convert MyString into an Array, so it is easy to save
MyArray = Split(MyString, ",")
'
'Where to save MyArray
Temp = Range(Cells(pos, 1), Cells(pos + UBound(MyArray), 1)).Address
'
'Save MyArray, The array is horizontal, transpose makes it vertical
Sheets("Search Results").Range(Temp).Value = Application.Transpose(MyArray)
'
'We need to increment pos so the next lot of data is saved below the existing data
pos = pos + UBound(MyArray)
'
End If
'
Skip:
Next
'This Adds Randomizer Column
With Sheets("Search Results")
'Number of times Loop is ran
For Count = 2 To pos - 1
Temp = CStr(Application.Trim(Sheets("Search Results").Cells(Count, 1)))
'
Range("B2:B" & Cells(Rows.Count, "A").End(xlUp).Row).Formula = "=Rand()"
Exit For
Next
'
Range("B2").Select
Selection.End(xlDown).Select
Selection.ClearContents
Selection.End(xlUp).Select
Selection.End(xlUp).Select
End With
'Copy and Paste Column A - Delete This and downward after Rand Set up
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range("A2:A1353").Select
Selection.Copy
Sheets("Rand").Select
ActiveSheet.Paste
'Select Row 1 Change back to (0, 1) if continued code isn't working
ActiveCell.Offset(-1, 1).Range("A1").Select
'Attempting to use cell contents as my find all criteria
'Continuing Code needs to go here
End SubSub SendMailsFromList()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim rng As Range
Dim Ash As Worksheet
Dim ws As Worksheet
Dim ebody As String
Dim i As Integer
ebody = "See below for your pay information for this pay period. If there are any errors please reach out to your team coach/supervisor." & "<br>"
Set Ash = ActiveWorkbook.ActiveSheet
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
For i = 1 To 171
For Each cell In Ash.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
Ash.Range("A1:AC171").AutoFilter Field:=2, Criteria1:=cell.Value
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Payroll file"
.HTMLBody = ebody & RangetoHTML(rng)
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Ash.AutoFilterMode = False
cell.Offset(1, 0).Select
Next i
cleanup:
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
If Dir(tmp5, vbDirectory) = vbNullString Then .CreateFolder tmp2
Option Explicit
Sub CreateFolder(ByVal Data_Table As Range, ByVal Data_Table1 As Range, ByVal Data_Table2 As Range, ByVal Data_Table3 As Range)
Dim tmpArr, tmpArr1, tmpArr2, tmpArr3, Arr(), Arr1(), Arr2(), Arr3()
Dim lR As Long, lC As Long
Dim tmp1 As String, tmp2 As String, tmp3 As String, tmp4 As String, tmp5 As String, sRoot As String, tmpsRoot As String, folder As String
On Error GoTo ExitSub
tmpArr = Data_Table2.Value
tmpArr1 = Data_Table1.Value
tmpArr2 = Data_Table.Value
tmpArr3 = Data_Table3.Value
sRoot = "M" & ":\" & Sheet1.Range("O1") & "\test\"
ReDim Arr(1 To UBound(tmpArr, 1), 1 To UBound(tmpArr, 2))
ReDim Arr1(1 To UBound(tmpArr1, 1), 1 To UBound(tmpArr1, 2))
ReDim Arr2(1 To UBound(tmpArr2, 1), 1 To UBound(tmpArr2, 2))
ReDim Arr3(1 To UBound(tmpArr3, 1), 1 To UBound(tmpArr3, 2))
With CreateObject("Scripting.FileSystemObject")
For lC = 1 To UBound(tmpArr, 2)
For lR = 1 To UBound(tmpArr, 1)
tmp1 = Trim(tmpArr(lR, lC))
tmp3 = Trim(tmpArr1(lR, lC))
tmp4 = Trim(tmpArr2(lR, lC))
If tmp4 = "Begin" Then
tmp3 = Replace(tmp3, Chr(47), "-") '47 /
tmpsRoot = sRoot & tmp3 & "\"
If Not .FolderExists(tmpsRoot) Then .CreateFolder tmpsRoot
End If
If tmp4 = "Dot" Then
Dim tam() As String
tmp1 = Replace(tmp1, Chr(47), "_") '47 /
tmp1 = Replace(tmp1, Chr(92), " ") '92 \
tmp1 = Replace(tmp1, Chr(42), " ") '42 *
tmp1 = Replace(tmp1, Chr(58), " ") '58 :
tmp1 = Replace(tmp1, Chr(34), " ") '34 "
tmp1 = Replace(tmp1, Chr(64), " ") '64 @
tmp1 = Replace(tmp1, Chr(62), " ") '62 >
tmp1 = Replace(tmp1, Chr(60), " ") '60 <
tmp1 = Replace(tmp1, Chr(124), " ") '124 |
tmp1 = Replace(tmp1, " ", " ")
If lC = 1 Then
tmp2 = tmpsRoot & tmp1
tmp5 = tmpsRoot & Trim(tmpArr3(lR, lC)) & Chr(42)
Else
tmp2 = Arr(lR, lC - 1) & "\" & tmp3 & " " & tmp1
End If
Arr(lR, lC) = tmp2
'folder = Len(Dir(tmp5, vbDirectory))
If Dir(tmp5, vbDirectory) = vbNullString Then .CreateFolder tmp2
'If Not .FolderExists(folder) Then .CreateFolder tmp2
End If
Next
Next
End With
ExitSub:
End Sub
Sub Main()
Dim SrcRng As Range, SrcRng1 As Range, SrcRng2 As Range, SrcRng3 As Range
Set SrcRng = Sheet2.Range("A1:A3000")
Set SrcRng1 = Sheet2.Range("B1:B3000")
Set SrcRng3 = Sheet2.Range("D1:D3000")
Set SrcRng2 = Sheet2.Range("E1:E3000")
CreateFolder SrcRng, SrcRng1, SrcRng2, SrcRng3
End Sub
Sub Del()
Sheet1.Range("A1:E3000").ClearContents
End Sub
Sub paste()
Worksheets("Sheet1").Range("A1").Select
ActiveSheet.PasteSpecial NoHTMLFormatting:=True
End Sub
Sub auto()
paste
Main
Del
End Sub
Sub GetSKU()
Dim w1 As Worksheet
Dim w2 As Worksheet
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
Dim lr As Long
lr = w1.Range("A" & Rows.Count).End(xlUp).Row
Dim lr2 As Long
Dim i, k As Long
Dim L As Long
Dim S As String
Application.ScreenUpdating = False
For i = 1 To lr
If Left(w1.Range("A" & i), 4) = "SKU:" Then
L = Len(w1.Range("A" & i)) - 5
For k = 1 To w1.Cells(i - 1, 1).Value
lr2 = w2.Range("A" & Rows.Count).End(xlUp).Row
w2.Range("A" & lr2 + 1) = Right(w1.Range("A" & i), L)
w1.Range("A" & i).Offset(-1, 1).Copy w2.Range("B" & lr2 + 1)
Next
End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox ("Task Completed")
Dim LastRow
LastRow = Sheets("Sheet2").Range("A1048576").End(xlUp).Row
For r = 1 To LastRow
Sheets("Sheet2").Range("C" & r).Value = Sheets("Sheet2").Range("B" & r).Value
Sheets("Sheet2").Range("B" & r).Value = Sheets("Sheet2").Range("A" & r).Value
Next
Sheets("Sheet2").Range("A1").Value = "Decals Needed"
For r = 2 To LastRow
Sheets("Sheet2").Range("A" & r).Formula = Application.WorksheetFunction.CountIf(Sheets("Sheet2").Range("B:B"), Sheets("Sheet2").Range("B" & r))
Next
Sheets("Sheet2").Range("A1:C" & LastRow).RemoveDuplicates Columns:=Array(1, 2, 3), _
Header:=xlYes
End SubSub copyDataFromMultipleWorkbooksIntoMaster()
Dim FolderPath As String, FilePath As String, Filename As String
FolderPath = "C:\Users\hjaspaul\Desktop\Moses Data"
FilePath = FolderPath & "*.xls*"
Filename = Dir(FilePath)
Dim lastrow As Long, lastcolumn As Long
Do While Filename <> ""
Workbooks.Open (FolderPath & Filename)
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
lastcolumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Range(Cells(2, 1), Cells(lastrow, lastcolumn)).Copy
Application.DisplayAlerts = False
ActiveWorkbook.Close
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 13))
Filename = Dir
Loop
Application.DisplayAlerts = True
End SubPrivate Sub ComboBox1_Change()
Dim wsDest As Worksheet
Dim wsSource As Worksheet
Dim rngData As Range
Dim baris As Integer
Dim kolom As Integer
baris = Range("G17").Value
kolom = Range("M17").Value
Set wsDest = Worksheets("Displaypage")
Set wsSource = Worksheets("Source")
Set rngData = wsSource.Range("a1:c5")
wsDest.Range("a1:c5").ClearContents
If baris = -1 Then Exit Sub 'Nothing selected
rngData.Cells(1).Offset(baris, kolom).Resize(5, 3).Copy
wsDest.Range("a1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
End SubWith Sheets("Summary")
With .ListObjects("Summary").Range
.AutoFilter Field:=1, Criteria1:=">400000", Operator:=xlOr, Criteria2:=Array("<>440400", "<>440600", "<>440300")
.AutoFilter Field:=5, Criteria1:=">110", Operator:=xlAnd, Criteria1:="<105"
.SpecialCells(xlCellTypeVisible).Copy
End With
End With