VBA sheet to new workbook if specific cell populated - excel

I have a macro built that copies a single sheet from my workbook to a new workbook and saves the new workbook in a specific location. I have built out my source file and have 3 sheets (of 6) which possibly need to be added to the new saved file.
I would like save sheet 4 (the original) sheet to a new file, then look at sheet 2 and if c2 has a specific result, move the sheet to the new file, then look at sheet 17 and if c2 has a specific result, move the sheet to the new file.
And save.
My struggle is on referencing a specific cell to call the action.

My struggle is on referencing a specific cell to call the action.
you can use a button and assigned your created macro on it just to trigger the action.

#urdearboy
Sub Cleanup()
'
' Cleanup Macro
'
' Keyboard Shortcut: Ctrl+e
'
'This is some clean up stuff on a specific tab, somewhere after this I need to add the check of a specific cell and pull the full sheet.
Application.ScreenUpdating = False
'Get path for desktop of user PC
Path = Environ("USERPROFILE") & "\Desktop"
Sheets("Uploader").Cells.Copy
'Create new workbook and past copied data in new workbook & save to desktop
Workbooks.Add (xlWBATWorksheet)
ActiveWorkbook.ActiveSheet.Paste
ActiveWorkbook.ActiveSheet.Name = "Upload"
x = Weekday(Date, vbSaturday)
Select Case x
Case 1
x = 2
Case 2
x = 3
Case Else
x = 1
End Select
ActiveWorkbook.SaveAs Filename:=Path & "\" & "Upload " & Format(CStr(Date - x), "mmddyyyy") & ".xlsx"
' start email
Dim Outlook As Object, EMail As Object
Set Outlook = CreateObject("Outlook.Application")
Set EMail = Outlook.CreateItem(0)
With EMail
.To = "1"
.CC = "2"
.BCC = ""
.Subject = "File is Ready"
.Body = "Isn't Automation Amazing!?"
.Attachments.Add ActiveWorkbook.FullName ' To add active Workbook as attachment
'.Attachments.Add "" ' To add other files just use path, Excel files, pictures, documents pdf's ect.
.Display 'or use .Send to skip preview
End With
Set EMail = Nothing
Set Outlook = Nothing
'end email
ActiveWorkbook.Close savechanges:=True
Application.ScreenUpdating = True
ActiveWorkbook.Close savechanges:=False
End Sub

Related

Create VBA variable worksheet reference to email sheets based on cell value

I have a workbook which has individual sheets that house office data based on the office location (example; sheet named Chicago would have data for our Chicago office and so on and so forth). Currently on every sheet I have a button with an assigned macro that exports the sheet as a pdf and attaches it to a prefilled email that I can then send to that office's designated contact based on some code I found online that works perfectly. The email of the contact is located in the same cell in every sheet. (See code below). I only need to send this email to locations that haven't reached a certain benchmark.
Sub SendEmailBulk()
'Update 20131209
Dim Wb As Workbook
Dim ws As Worksheet
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
On Error Resume Next
Set Wb = ThisWorkbook
Set ws = Active.Sheet
FileName = Wb.FullName
xIndex = VBA.InStrRev(FileName, ".")
With ActiveSheet.PageSetup
.Orientation = xlLandscape
.FitToPagesTall = 1
.FitToPagesWide = 1
End With
If xIndex > 1 Then FileName = VBA.Left(FileName, xIndex - 1)
FileName = FileName & "_" + ActiveSheet.Name & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.SentOnBehalfOfName = "abc#xyz.com"
.To = ActiveSheet.Range("J10")
.CC = ""
.BCC = ""
.Subject = Range("C1") & " Data"
.Body = "abcxyz"
.Attachments.Add FileName
.Display
End With
Kill FileName
Set OutlookMail = Nothing
Set OutlookApp = Nothing
End Sub
What I would like to do is instead of having to check every sheet and send the emails individually to instead have some code that checks and emails only the required ones for me.
In another sheet I have a sheet called SUMMARY which contains a summary of all of our office locations in column B and a true or false counter setup that records whether they have achieved the benchmark in column C. I only need to send the above email to those locations who have not reached that benchmark (a FALSE value in column C).
I understand that I would need some code that checks the first row of the SUMMARY sheet for the first office location in Column B if it contains the FALSE value in Column C then, if so, assigns the value in Column B to a variable (lets say SheetName). Then the ActiveSheet reference would need to be replaced with WorkSheets("SheetName") to have the email code run before looping back around to check the second office location and so on until the end.
I have an idea of how this would work in theory I just don't have the exact VBA knowledge on how to write something to this effect. Any help would be greatly appreciated.

Save zip attachments from Outlook in an internal drive (folder)

I work in bank and we have a lot of restrictions. I can't use the Developer option in Outlook. I can use Excel VBA.
I would like to automate saving a zip file, which is received everyday, in a local drive folder and automatically unzip it and replace the yesterday's file.
I would like to create a button in an Excel sheet. Once I press the button the attachment in Outlook should save in a local folder in whatever destination I want and the attachment should unzip.
I have tried some things saving attachments from Outlook by using VBA, but it doesn't help much.
I am not surprised a bank doesn’t want its emails accessed. You could change the sender, add or remove recipients or change the text. It is difficult to do any of these without leaving a trail but it is possible. You do not want to change anything; you just want to automate saving an attachment so this might be allowed by your tech people and Outlook.
Before attempting the more complicated parts of your requirement, let us check your requirement is possible. I do not know how much you know about Excel VBA. If I ask you to do something you do not understand, come back with questions.
Create a macro-enabled workbook somewhere convenient. The name of the workbook does not matter.
Open the workbook and then the VBA Editor.
Click [Tools] and then [References]. You will get a drop-down menu of all the available libraries. Scroll down until you find “Microsoft Outlook nn.0 Object Library”. “nn” identifies the version of Outlook in use which I understand will be “14” for you. Click the box to the left and a tick will appear. Click [OK]. This will give you access to Outlook from Excel.
In the Project Explorer, you will see something like:
- VBAProject (YourNameForWorkbook.xlsm)
- Microsoft Excel Objects
Sheet1 (Sheet1)
ThisWorkbook
If either of the minuses is a plus, click that plus.
Click [ThisWorkbook]. An empty code area will appear on the right of the VBA Editor window. Copy the code below to this area.
Within the code you will find lines starting ‘###. These lines tell you about changes you must make or things you must check. Make the necessary changes and then save and close the workbook. Reopen the workbook. With good fortune, the macro will run automatically and the default worksheet will report what it has done. It will probably have found the wrong email and saved the wrong attachment. This does not matter. If you can save any attachment, you can save the attachment you want.
Option Explicit
Sub Workbook_Open()
'### Replace "C:\DataArea\SO\" with the name of a disc folder on your system
' Make sure your folder name ends with \.
Const DiscFldrDest As String = "C:\DataArea\SO\"
'### The name of the default worksheet depend on the local language. Replace
' "Sheet1" is this is not the default name for you.
Const WshtOutName As String = "Sheet1"
' ### The subject of the email. Correct if I have misunderstood your comment ' ###
Const Subject As String = "ISIN List: Financial Sanctions - ISIN screening" ' ###
Dim AppOut As Outlook.Application
Dim Found As Boolean
Dim InxA As Long
Dim InxI As Long
Dim OutFldrInbox As Outlook.Folder
Dim RowNext As Long
Dim WshtOut As Worksheet
Set AppOut = CreateObject("Outlook.Application")
With AppOut
With .Session
Set OutFldrInbox = .GetDefaultFolder(olFolderInbox)
End With
End With
Set WshtOut = Worksheets(WshtOutName)
RowNext = WshtOut.Cells(Rows.Count, "A").End(xlUp).Row + 1
'### Change if you prefer different date or time formats
WshtOut.Cells(RowNext, "A").Value = "Macro activated at " & _
Format(Now(), "h:mm") & " on " & _
Format(Now(), "d mmm yy")
RowNext = RowNext + 1
'### GetDefaultFolder is not much use on my system because I have two
' email addresses, each with their own Inbox, neither of which is
' the default Inbox. Probably you only have one work email address
' which is the default for you. To check, the following statement
' outputs the name of the default Inbox's mailbox. Tell me if it is
' not the mail box you want.
WshtOut.Cells(RowNext, "A").Value = Space(6) & "Inbox accessed"
WshtOut.Cells(RowNext, "B").Value = OutFldrInbox.Parent.Name
RowNext = RowNext + 1
Found = False
With OutFldrInbox
For InxI = .Items.Count To 1 Step -1
With .Items(InxI)
If .Subject = Subject And .Attachments.Count > 0 Then '###
WshtOut.Cells(RowNext, "A").Value = Space(6) & "Attachment saved from email" '###
WshtOut.Cells(RowNext, "B").Value = "With subject"
WshtOut.Cells(RowNext, "C").Value = .Subject
RowNext = RowNext + 1
WshtOut.Cells(RowNext, "B").Value = "Received"
'WshtOut.Cells(RowNext, "C").Value = .ReceivedTime
WshtOut.Cells(RowNext, "C").Value = Format(.ReceivedTime, "\a\t h:mm \o\n d mmm yy")
'WshtOut.Cells(RowNext, "C").NumberFormat = "at h:mm on d mmm yy"
RowNext = RowNext + 1
WshtOut.Cells(RowNext, "A").Value = Space(6) & "Attachment saved" '###
For InxA = 1 To .Attachments.Count '###
If UCase(Right$(.Attachments(InxA), 4)) = ".ZIP" Then '###
WshtOut.Cells(RowNext, "B").Value = .Attachments(InxA).Filename '###
.Attachments(1).SaveAsFile DiscFldrDest & .Attachments(1).Filename '###
Found = True '###
Exit For '###
End If '###
Next '###
End If
End With
Next
With WshtOut
If Not Found Then
.Cells(RowNext, "B").Value = "No email with correct subject and a ZIP attachment found"
RowNext = RowNext + 1
End If
.Columns.AutoFit
.Cells(RowNext, "A").Select
End With
End With
End Sub

How to check if a range contains a word?

I have 3 Excel files that have in the column B the comments: ok or check. Column C contains the product numbers of the products that are either ok or need to be checked. I want to create a list (an overview) in another Excel file (4) of all the products that have the word "check" in column B in the other three Excel files (1,2,3).
I cannot use a pivot table in the three excels because it has to be refreshed manually.
Filter is also not an option. I would like to use VBA/Macros in Excel.
Excel 1
Status Product number
check 1254968
ok 5541485
check 2153654
ok 4588999
ok 8954668
ok 6945665
check 7469968
check 6665448
Excel 2
Status Product number
ok 7455561
ok 5145684
ok 4589666
check 4896471
check 1117347
check 5656478
ok 5256488
Excel 3
Status Product number
ok 3389741
check 6754889
check 1489798
ok 6489646
Excel 4
Products to check
1254968
2153654
7469968
6665448
4896471
1117347
5656478
6754889
1489798
I expect to have a list with all the product numbers that need to be checked in my 4th. Excel.
Create a new workbook in the same folder as the other files are located. Please consider to move away any other .xlsx files before running this macro :) If you need to run it in a specific folder and you are not able to move the files, please include a condition based on the name of the files that you do want to use. Otherwise, the below should be sufficient. Please read all comments in the code.
Sub test()
Dim wb1, wb2 As Workbook
Dim HeadSet As Boolean
Set wb1 = ThisWorkbook
FolderName = "your/path/" 'full path name to folder where xlsx is located
file_name = Dir(FolderName & "*" & ".xlsx", vbDirectory) 'assuming the files are all .xlsx
HeadSet = False 'for fun
'for each file in FolderName
Do While Right(file_name, 5) = ".xlsx" And file_name <> ""
'open workbook
Set wb2 = Workbooks.Open(file_name, False, True)
With wb2.Sheets(1)
For i = .Range("B1").End(xlDown).Row To .Range("B20000").End(xlUp).Row 'change .sheets(1) 1 = index to > your index, or "sheetname"
If LCase(Trim(.Range("B" & i).Value)) = "check" Then 'checks lowercase, so condition should be lower
'create headers in output sheet
If HeadSet = False Then
wb1.Sheets(1).Range("A1").Value = "Products"
wb1.Sheets(1).Range("A1").Value = "Result of check"
HeadSet = True
End If
'change wb1.sheets(index) to your index, or the sheet name between ""
wb1.Sheets(1).Range("A" & wb1.Sheets(1).Range("A20000").End(xlUp).Row + 1).Value = .Range("C" & i).Value
wb1.Sheets(1).Range("B" & wb1.Sheets(1).Range("A20000").End(xlUp).Row + 1).Value = .Range("B" & i).Value
End If
Next i 'next iteration
End With
wb2.Close False 'close workbook
file_name = Dir 'go to next file
Loop
End Sub

Enable macro on a single workbook

So, I'm working on an automation project and have stumbled on a roadblock because I can't call anything on a downloaded Excel file.
When I try opening the Excel file manually, its VB Editor is disabled... All other opened Excel files have it enabled.
I'm using below for downloading/opening the said Excel (XLSX) file.
Sub GetLogins()
Application.ScreenUpdating = False
NavSheet.Unprotect [pw]
Dim LoginWkbk As Workbook, LoginWksht As Worksheet
Dim WinHTTPRequest As Object, ADOStream As Object
Dim URL As String
Dim FileRev As Long, LastRow As Long, x As Long
Dim ts As Double
ts = Timer
FileRev = [Revision] ' The current logins file revision
FileRev = FileRev + 1 ' Check for the next revision. Hah!
TryAgain:
If Password = "" Then AcctLoginsForm.Show ' Password not (yet?) supplied
' Second line of security.
If Username = "" Or Password = "" Then
' This checks if the user provided the complete information required.
' If they didn't we would clear the admin logins sheet of any information that was in there.
Call ClearAcctsSheet
MsgBox "Insufficient information submitted.", vbOKOnly, "Window_Title"
GoTo ExitSub
End If
' The logins file URL
URL = "https://mysecreturl" & FileRev & ".xlsx"
Set WinHTTPRequest = CreateObject("Microsoft.XMLHTTP")
With WinHTTPRequest
' "GET" command with username and password
.Open "GET", URL, False, Username, Password
.Send
Select Case .Status
Case 401
' Incorrect credentials.
If MsgBox("Incorrect Username/Password supplied. Try again?", vbYesNo, "Window_Title") = vbYes Then
Call ClearAcctsSheet
Password = ""
GoTo TryAgain
Else
GoTo ExitSub
End If
Case 404
' The next revision is not yet uploaded, so we set to download the previous revision
FileRev = FileRev - 1
GoTo TryAgain
Case 200
' Set the "Revision" named range to the current file revision
[Revision] = FileRev
End Select
Set ADOStream = CreateObject("ADODB.Stream")
ADOStream.Open
ADOStream.Type = 1
ADOStream.Write .ResponseBody
ADOStream.SaveToFile Environ$("temp") & "\logins.xlsx", 2 ' Save the file in the temp file overwriting if the file exists
ADOStream.Close
End With
' Need to clear out the Accounts Sheet fields before populating it with the new credentials
AcctsSheet.Range("A:C").ClearContents
Set LoginWkbk = Workbooks.Open(Environ$("temp") & "\logins.xlsx")
Set LoginWksht = LoginWkbk.Sheets(1)
LastRow = LoginWksht.Cells(Rows.Count, 1).End(xlUp).Row ' Last row. Duh.
For x = 1 To LastRow
' Copy-pasting the information from the logins file crashes Excel, hence this for-loop.
AcctsSheet.Range("A" & x).Value = LoginWksht.Range("A" & x).Value
AcctsSheet.Range("B" & x).Value = LoginWksht.Range("G" & x).Value
AcctsSheet.Range("C" & x).Value = LoginWksht.Range("H" & x).Value
Application.StatusBar = "Extraction complete. Time elapsed: " & Round(Timer - ts, 2)
If LoginWksht.Range("A" & x).Value = "" Then
Exit For
End If
Next x
LoginWkbk.Close False ' Close the logins file
Kill Environ$("temp") & "\logins.xlsx" ' Delete the logins file
[DateToday] = Format(Now, "m/d/yyyy") ' Set the "DateToday" named range to the current day.
ExitSub:
NavSheet.Protect [pw]
NavSheet.Activate
ThisWorkbook.Save
SetToNothing WinHTTPRequest, ADOStream, LoginWkbk, LoginWksht
Application.ScreenUpdating = True
End Sub
I can open the Excel file with Workbooks.Open, but the opened XLSX file is not listed in the VBAProject window so I can't call anything on the sheet.
Has anyone encountered this here? Can we force-enable the macro settings on a single workbook?
A .xlsx file cannot have macros. In my test, the VB editor is not disabled, there are just no macros in the file to show. If you have macros enabled in Excel settings, then the workbook may still need to be in a Trusted Location for Excel to allow macros to run.

Sending multiple worksheets in same workbook via VBA macro through Outlook Email?

I would like to copy multiple worksheets (for example, Sheet71, Sheet76, Sheet60, and Sheet77) that are located within one workbook into another workbook to send in an email to a recipient that is outlined within my email key sheet on Sheet 71.
These emails will be sent to individuals to outline their bonus pay.
Therefore, it is critical that the recipients only receive their own or who they are responsible for.
I have figured out how to send one single worksheet to one recipient, but cannot figure out how to accomplish this with multiple worksheets without using the name on the worksheet (Pierce Group Matrix, Shuff Matrix, Gamble Matrix, and Reed Matrix) versus Sheet71, Sheet76, Sheet60, and Sheet77 in VBA.
I need to be able to reference within the macro to the sheet number rather than the name, because turnover does happen.
Below is the code that I wrote to send an email to one individual in my email key sheet (Sheet81) with one worksheet but it only sends Sheet 71.
I have tried the Array keyword and multiple other keywords but can't seem to get it to work.
I need to reference to the Sheet number rather than the Sheet name because the names are changed when people are replaced.
I would prefer to make a copy like the below code does, but I am open to try a Select command if that will work.
Sub Mail()
Dim OutlookApp As Object
Dim Mess As Object, Recip
Recip = Sheet81.[C35].Value
newDate = MonthName(Month(DateAdd("m", -1, Date)), False)
' Make a copy of the active worksheet
' and save it to a temporary file
Sheet71.Copy
Set WB = ActiveWorkbook
Filename = WB.Worksheets(1).Name
On Error Resume Next
Kill "C:\" & Filename
On Error GoTo 0
WB.SaveAs Filename:="C:\" & Filename
Set OutlookApp = CreateObject("Outlook.Application")
Set Mess = OutlookApp.CreateItem(olMailItem)
With Mess
.Subject = (newDate + " Matrix")
.Body = ("Attached is your " + newDate + " bonus matrix. Thanks! Neil")
.to = Recip
.Attachments.Add WB.FullName
.Display
.Send
End With
ActiveWorkbook.Close
Set OutlookApp = Nothing
Set Mess = Nothing
End Sub
In this method, I elected to create a new sub routine called sendMultMails. This will create a collection of worksheets that you choose to add. Since you do not want to use the sheet name as the reference, I used the sheet's CodeName.
So, add your sheets to the collection and loop that collection. Within the loop, you will call your other routine Mail, passing the sheet as a parameter.
Sub sendMultMails()
Dim wsColl As New Collection, ws As Worksheet
Rem: Add your worksheets to the collection via the worksheet's CodeName
With wsColl
.Add Sheet71
.Add Sheet76
.Add Sheet60
.Add Sheet77
End With
Rem: loop through each collection item, calling the Mail Routine
For Each ws In wsColl
Mail ws
Next
End Sub
Rem: Added an argument for you to pass the ws obj to this routine
Sub Mail(ws As Worksheet)
Dim OutlookApp As Object
Dim Mess As Object, Recip
Recip = ws.Range("C35").Value
newDate = MonthName(Month(DateAdd("m", -1, Date)), False)
' Make a copy of the active worksheet
' and save it to a temporary file
ws.Copy
Set WB = ActiveWorkbook
Filename = WB.Worksheets(1).Name
On Error Resume Next
Kill "C:\" & Filename
On Error GoTo 0
WB.SaveAs Filename:="C:\" & Filename
Set OutlookApp = CreateObject("Outlook.Application")
Set Mess = OutlookApp.CreateItem(olMailItem)
With Mess
.Subject = (newDate + " Matrix")
.Body = ("Attached is your " + newDate + " bonus matrix. Thanks! Neil")
.to = Recip
.Attachments.Add WB.FullName
.Display
.Send
End With
ActiveWorkbook.Close
Set OutlookApp = Nothing
Set Mess = Nothing
End Sub
You could use the WB.Worksheets(1).CodeName to reference the Sheet number.
the CodeName property is read-only
You can reference a particular sheet as Worksheets("Fred").Range("A1") where Fred is the .Name property or as Sheet1.Range("A1") where Sheet1 is the codename of the worksheet.
For more information, you could refer to this link:
Excel tab sheet names vs. Visual Basic sheet names

Resources