I have many projects where I have the same variables across multiple modules. In each module I dim and set the variables and each time they are the same variable type and have the same value. How do I dim and set variables across an entire project/workbook?
Ex: (I have many modules in a workbook where I have had to repeat all of the following along with many other similar variables that do not change across modules)
Sub PullSFAFiles()
Dim Wb As Workbook
Dim WsSFAFiles As Worksheet
Dim WsAllCourses As Worksheet
Dim rngAllCourses As Range
Dim rngCourse As Range
Dim LoSFAFiles As ListObject
Dim rngPreviousFiles As Range
Dim rngRemoveLines As Range
Dim strCourse As String
Dim strApp As String
Dim strPeCFldrPath As String
Dim strFileLocation As String
Dim strFileNm As String
Dim objFile As Object
Dim intSFARow As Integer
Dim intCourseRow As Integer
Dim intPFilesRow As Integer
Dim dtLastUpdate As Date
Dim intNumRemove As Integer
Set Wb = ThisWorkbook
Set WsSFAFiles = Wb.Sheets("sfafiles")
Set WsAllCourses = Wb.Sheets("allcourses")
Set rngAllCourses = WsAllCourses.Range("tblAllCourses[CourseName]")
Set LoSFAFiles = WsSFAFiles.ListObjects("tblSFAFiles")
strEBTypeFolder = "Exercise Booklet"
strEBfiletype = "EB"
strCISTypeFolder = "Classroom Information Sheet"
strCISfiletype = "CIS"
intCourseRow = rngCourse.Row - 1
strCourse = rngCourse.Value
strApp = WsAllCourses.Range("tblallcourses[application]").Rows(intCourseRow)
strPeCFldrPath = "\\Cx138\training\Live\Credentialed Trainers\"
strEBFileLocation = strApp & "\" & strTypeFolder & "\" & strCourse & "_" & strEBfiletype & "*" & ".pdf"
strEBFileNm = Dir(strPeCFldrPath & "\" & strEBFileLocation)
strCISFileNm = Dir(strPeCFldrPath & "\" & strCISFileLocation)
Replace variable declaration Dim with Public. Thus:
Public rngCourse as Range
Public strCourse As String
Declare them at module level.
Related
I'm quite new with VBA and am trying to use a code that I found online. However, when I run the code I get the error that I'm having a bad file name or number. When I look in the Locals window the path and file name seem to be expressed. Does anyone have an idea how to fix this?
Public Sub Create_KMZ_File_Filled_Circles()
Dim KMLfileName As String, KMZfullName As String
Dim KMLfullName As Variant, ZIPfullName As Variant 'must be Variants for WShell functions
Dim folderPath As String
Dim data As Variant
Dim WShell As Object
Dim fn As Integer
Dim Circle_Coords() As Double
Dim i As Long, r As Long
folderPath = ThisWorkbook.Path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
KMLfileName = "Circles Filled.kml"
KMLfullName = folderPath & KMLfileName
KMZfullName = Replace(KMLfullName, ".kml", ".kmz")
'Put sheet data in array
data = ThisWorkbook.Worksheets("Sheet1").UsedRange
fn = FreeFile
Open KMLfullName For Output As #fn
I'm working with sharepoint - could that create the issue?
I have some .html files which I want to read with vba. I wrote this codes to do what I want but I get
object variable or with block variable not set
error.
Dim arrListATA() As String
Dim arrListTaskNo() As String
Dim arrListDesc() As String
Dim arrIssueNo() As String
Dim arrIssueDate() As String
Dim arrPartNo() As String
Dim arrDMC() As String
Dim arrApplicability() As String
Dim arrDMCModelCode() As String
Dim DMCs As String
Dim arrSubTask() As String
Dim subTasks As String
Dim subs() As Variant
Dim subs1 As String
k = 0
Dim objFile As Scripting.File
Dim objFolder As Scripting.Folder
Set objFSO = CreateObject("Scripting.FileSystemObject")
w = 0
m = 0
b = 0
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
fd.Filters.Clear
If fd.Show = -1 Then
myTopFolderPath = fd.SelectedItems(1)
Set objFolder = objFSO.GetFolder(myTopFolderPath)
Dim arrSplitedDMC As Variant
Dim arrSubTasks As Variant
For Each objFile In objFolder.Files
Debug.Print myTopFolderPath & "\" & objFile.Name
If Right(objFile.Name, 4) = "html" And Len(objFile.Name) = 33 And Left(objFile.Name, 8) <> "V2500-00" Then
Debug.Print myTopFolderPath & "\" & objFile.Name
Workbooks.Open Filename:=myTopFolderPath & "\" & objFile.Name
Debug.Print "Opened"
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
taskCheckFlag = False
myTemp = ""
partNoFlag = False
mySubTask = ""
For i = 1 To lastrow
txt = Cells(i, 1)
Next i
My folder path and my object names like this
C:\Users\ftk1187\Desktop\V2500 - Copy\V2500-00-70-72-02-00A-363A-D.html
It's not opening my .html files. How can I solve this problem?
The code below actually runs.
Option Explicit
Private Sub Test()
Dim arrListATA() As String
Dim arrListTaskNo() As String
Dim arrListDesc() As String
Dim arrIssueNo() As String
Dim arrIssueDate() As String
Dim arrPartNo() As String
Dim arrDMC() As String
Dim arrApplicability() As String
Dim arrDMCModelCode() As String
Dim DMCs As String
Dim arrSubTask() As String
Dim subTasks As String
Dim subs() As Variant
Dim subs1 As String
Dim objFSO As FileSystemObject
Dim Fd As FileDialog
Dim objFile As Scripting.File
Dim objFolder As Scripting.Folder
Dim arrSplitedDMC As Variant
Dim arrSubTasks As Variant
Dim myTopFolderPath As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set Fd = Application.FileDialog(msoFileDialogFolderPicker)
' k = 0
' w = 0
' m = 0
' b = 0
With Fd
.Filters.Clear
If .Show = -1 Then
myTopFolderPath = .SelectedItems(1)
Set objFolder = objFSO.GetFolder(myTopFolderPath)
For Each objFile In objFolder.Files
Debug.Print myTopFolderPath & "\" & objFile.Name
Debug.Print myTopFolderPath
Debug.Print objFile.Name
Debug.Print Right(objFile.Name, 4), Len(objFile.Name), Left(objFile.Name, 8)
' If Right(objFile.Name, 4) = "html" And Len(objFile.Name) = 33 And Left(objFile.Name, 8) <> "V2500-00" Then
' Debug.Print myTopFolderPath & "\" & objFile.Name
' Workbooks.Open Filename:=myTopFolderPath & "\" & objFile.Name
' Debug.Print "Opened"
'
' lastrow = Cells(Rows.Count, 1).End(xlUp).Row
' taskCheckFlag = False
' myTemp = ""
' partNoFlag = False
' mySubTask = ""
'
' For i = 1 To lastrow
' txt = Cells(i, 1)
' Next i
Next objFile
End If
End With
End Sub
You will see that I added Option Explicit at the top and a few declarations that were missing. The variables k, w, m and b are also not declared but if they are numbers their value should already be 0 at that point of the code. According to my research, Excel should be able to open an HTML file but I wonder what it might show.
As a general piece of advice, I would recommend that you construct your code as one Main subroutine which calls other subs and functions, each of them no larger than 10 to 25 lines of code. In your code you already exceed that number in your declarations. The effect is a construct that you can't control.
Here is what I have been given to try and create:
User creates an email a few times per week and has to re-type everything, a request for employee updates, with up to 5 people on it. Easy enough to create in VBA, except that the employees could change each time. So there could be just 1 person, or 2, or 3, etc...and each time it could be a different mix of the employees. They want input boxes that would prompt how many employees for the email, then based on that input, follow-up boxes (if more than 1) that allow the input of the names (1 per box). It then needs to create the email, placing the input box data into the body text. Each email text will be based on the input from the 1st input box, so it can adjust for the number of employees (so there could be up to 5 employees on each email).
How do I assign values to my variables (findstrs and foundcells)so that they will adjust to the inputs of the inputboxes without writing all the IF stmts?
Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim strbox As String
Dim stritem As String
Dim X As Long
Dim r As Long
Dim LR, lookrng As Range
Dim findStr As String
Dim nameCol As Range
Dim nameCol1 As Range
Dim nameCol2 As Range
Dim nameCol3 As Range
Dim nameCol4 As Range
Dim foundCell As Variant
Dim foundCell1 As Variant
Dim foundcell2 As Variant
Dim strname As String
Dim strBody As String
Dim sigString As String
Dim signature As String
Dim findstr1 As String
Dim foundrng As Range
Dim valuefound As Boolean
Dim strFilename As String
Select Case Application.ActiveWindow.Class
Case olInspector
Set oMail = ActiveInspector.CurrentItem
Case olExplorer
Set oMail = ActiveExplorer.Selection.Item(1)
End Select
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
Set oReply = oMail.ReplyAll
Select Case Application.ActiveWindow.Class
Case olInspector
Set oMail = ActiveInspector.CurrentItem
Case olExplorer
Set oMail = ActiveExplorer.Selection.Item(1)
End Select
Set aOutlook = CreateObject("Outlook.Application")
Set oReply = aOutlook.CreateItem(0)
'Input box(es)
findStr = InputBox("Enter Number of Employees")
findstr1 = InputBox("Enter Name of First Employee")
If findStr = "2" Then findstr2 = InputBox("Enter Name of Second Employee")
If findstr1 = "T1" Then foundCell1 = "<B>Test 1 ID#0000</B>"
If findstr1 = "T2" Then foundcell2 = "<B>Test 2 IDO#0001</B>"
If findstr1 = "T3" Then foundcell3 = "<B>Test 3 ID#0002</B>"
If findstr1 = "T4" Then foundCell4 = "<B>Test 4 ID#0003</B>"
If findstr1 = "T5" Then foundCell5 = "<B>Test 5 ID#0004</B>"
If findstr2 = "T1" Then foundCell1 = "<B>Test 1 ID#0000</B>"
If findstr2 = "T2" Then foundcell2 = "<B>Test 2 IDO#0001</B>"
If findstr2 = "T3" Then foundcell3 = "<B>Test 3 ID#0002</B>"
If findstr2 = "T4" Then foundCell4 = "<B>Test 4 ID#0003</B>"
If findstr2 = "T5" Then foundCell5 = "<B>Test 5 ID#0004</B>"
'Greeting based on time of day
Select Case Time
Case 0.25 To 0.5
GreetTime = "Good morning"
Case 0.5 To 0.71
GreetTime = "Good afternoon"
Case Else
GreetTime = "Good evening"
End Select
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Update.htm"
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
If findStr = "1" Then
strBody = "<Font Face=calibri>Can you please update the following: <br><br>" & _
"<B>" & foundCell1 & "</B><br><br>" & _
"Please update this batch. " & _
"I Appreciate your help. Let me know if you need anything.<br><br>" & _
"Thanks <br><br>" & _
subject = "Employee Update"
ElseIf findStr = "2" Then
strBody = "<Font Face=calibri>Can you please add changes for the following: " & _
"<ol><li><B>" & foundCell1 & "</B><br><br><br><br>" & _
"<li><B>" & foundcell2 & "</B><br><br>" & _
subject = "Multiple Employee Requests"
End If
'Sets up the email itself and then displays for review before sending
With oReply
.HTMLBody = "<Font Face=calibri>Hi there,<br><br>" & strBody & signature
.To = "superman#krypton.com"
.CC = "trobbins#shawshank.com "
.subject = "Multiple Employee Updates"
.Importance = 2
.Display
End With
End Sub
You need to break this code down into multiple, smaller and parameterized scopes.
Make a Function that returns the body of the email given a Collection of batch numbers.
Private Function GetEmailBody(ByVal batchNumbers As Collection) As String
Now, the calling code needs to know how many employees there are. Make a function for that.
Private Function GetNumberOfEmployees() As Long
Dim rawInput As Variant
rawInput = InputBox("Number of employees?")
If StrPtr(rawInput) = 0 Then
'user cancelled out of the prompt
GetNumberOfEmployees = -1
Exit Function
Else If IsNumeric(rawInput) Then
GetNumberOfEmployees = CLng(rawInput)
End If
End Function
That'll return -1 if user cancels the prompt, 0 for an invalid input, and the number of employees otherwise.
Dim employeeName As String
Dim nbEmployees As Long
nbEmployees = GetNumberOfEmployees
If nbEmployees = -1 Then
Exit Sub 'bail out
Else If nbEmployees = 0 Then
'reprompt?
Exit Sub 'bail out, cancelled
End If
'fun part here
Dim emailbody As String
emailBody = GetEmailBody(batchNumbers, employeeName)
And now the fun part: you need to add as many items to some batchNumbers collection, as you have nbEmployees. Because you know how many iterations you'll need before you start looping, a For loop will do.
Dim batchNumbers As Collection
Set batchNumbers = New Collection
Dim batchNumber As String
Dim i As Long
For i = 1 To nbEmployees
batchNumber = GetBatchNumber(i)
If batchNumber = vbNullString Then Exit Sub 'bail out:cancelled/invalid
batchNumbers.Add batchNumber
Next
Dim body As String
body = GetEmailBody(batchNumbers)
Where GetBatchNumber(i) is yet another function call, to a function whose role it is to prompt for an employee number and lookup & return the corresponding batch number, returning an empty string if prompt is cancelled or no match is found.
Private Function GetBatchNumber(ByVal index As Long) As String
Dim rawInput As Variant
rawInput = InputBox("Name of employe " & index & ":")
If StrPtr(rawInput) = 0 Then
'cancelled
Exit Function
Else
Dim employeeName as String
employeeName = CStr(rawInput)
GetBatchNumber = GetBatchForEmployee(employeeName)
End If
End Function
If the mappings really actually look like T1 -> <B>Test 1 ID#000</B> then you can probably use this:
Private Function GetBatchForEmployee(ByVal employeeName As String)
Dim digit As Long
digit = CLng(Right$(employeeName, 1))
GetBatchForEmployee = "<B>Test " & digit & " ID#" & Format$(digit - 1, "000") & "</B>"
End Function
If your mappings are actual mappings then you can have a Dictionary lookup in here, or look them up on an Excel worksheet, a CSV or XML data file, a SQL Server database, whatever.
But first, break things down. A procedure that starts like this:
Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim strbox As String
Dim stritem As String
Dim X As Long
Dim r As Long
Dim LR, lookrng As Range
Dim findStr As String
Dim nameCol As Range
Dim nameCol1 As Range
Dim nameCol2 As Range
Dim nameCol3 As Range
Dim nameCol4 As Range
Dim foundCell As Variant
Dim foundCell1 As Variant
Dim foundcell2 As Variant
Dim strname As String
Dim strBody As String
Dim sigString As String
Dim signature As String
Dim findstr1 As String
Dim foundrng As Range
Dim valuefound As Boolean
Dim strFilename As String
...is a procedure that's doing way too many things.
I am working on a excel newly jfor 1 weeks where i want to compare opened excel file current open file,
I made all possible but whenever I try to read the row, it only reading the value from the opened , I cant' able to access to read current workbook where i my macro was coded
Sub test1()
Dim iComp
Dim sheet As String
Dim wbTarget As Worksheet
Dim wbThis As Worksheet
Dim bsmWS As Worksheet
Dim c As Integer
Dim x As Integer
Dim strValue As String
Static value As Integer
Dim myPath As String
Dim folderPath As String
k = 3
Filename = Application.GetOpenFilename("Excel files (*.xls*),*.xl*", Title:="Open data") ' Choosing the Trigger Discription
'Set wbTarget = ActiveWorkbook.ActiveSheet
Set theRange = Range("A2:A4")
c = theRange.Rows.Count
strValue = vbNullString
For x = 1 To c
strValue = strValue & theRange.Cells(x, 1).value
Next x
'Set tabWS = Sheets("Tabelle1")
folderPath = Application.ActiveWorkbook.Path
myPath = Application.ActiveWorkbook.FullName
Set bsmWS = Sheets("Tabelle1")
Set wbkA = Workbooks.Open(Filename:="myPath")
Set varSheetA = wbkA.Worksheets("Balance sheet").Range(strRangeToCheck)
Its a 1000 line code , I just put only snippet.
I have myworksheet in the workbook where I am programed . I want to open another worksheet, take the value and compare it with my current worksheet . If string matches (ex range (A1:A2)) then msgbox yes
Have you tried using ThisWorkbook.Sheets("sheet name").Range("A2:A4") or ThisWorkbook.ActiveSheet.Range("A2:A4"). This will ensure the reference is to the workbook where the code is located.
More info on Application.ThisWorkbook
https://msdn.microsoft.com/en-us/library/office/ff193227.aspx.
I have been trying to work on powerpoint that has an excel database in background.
For now I am having trouble passing sheets as arguement in PPT VBA. The function lastrow and lastcoulmn return an error that "user-defined type not defined". Help would be appreciated. thanks.
Dim oXLApp As Object
Dim oWb As Object
Dim Deps As Excel.Range
Dim Dep, Shift, Name, EmpNo, Sup As String
Dim Sups As Excel.Range
Dim Shifts As Excel.Range
Public Sub getexceldata()
Dim str As String
Set oXLApp = CreateObject("Excel.Application")
Set oWb = oXLApp.Workbooks.Open(ActivePresentation.Path & "\" & "Property Wide.xlsm")
'Shifts
Set Shifts = oWb.Sheets(4).Range("A1:A" & lastRow(oWb.Sheets(4), "a"))
'departments
Set Deps = oWb.Sheets(3).Range("A1:" & Chr(lastColumn(oWb.Sheets(3), "1") + 64) & "1")
'supervisors
End Sub
Public Function lastRow(ByVal SheetA As Excel.Application.Sheet, Optional Columnno As Char = "/") As Long
If (Columnno = "/") Then
Set lastRow = SheetA.UsedRange.Row - 1 + SheetA.UsedRange.Rows.Count
Else
Set lastRow = SheetA.Range(Columno & Rows.Count).End(xlUp).Row
End If
End Function
Public Function lastColumn(ByVal SheetA As Excel.Application.Sheet, Optional rowno As Char = "/") As Integer
If (rowno = "/") Then
Set lastColumn = SheetA.UsedRange.Column - 1 + SheetA.UsedRange.Columns.Count
Else
Set lastColumn = SheetA.Cells(rowno, Columns.Count).End(xlToLeft).Column
End If
End Function
The first issue is that CHAR is not a valid variable type so I would suggest changing this to string.
Next make sure to include the Microsoft Office Excel 14.0 Object Library in your code reference.
With that you can make some slight adjustment to your code an everything should work.
Dim oXLApp As Object
Dim oWb As Object
Dim Deps As Excel.Range
Dim Dep, Shift, Name, EmpNo, Sup As String
Dim Sups As Excel.Range
Dim Shifts As Excel.Range
Public Sub getexceldata()
Dim str As String
Set oXLApp = CreateObject("Excel.Application")
Set oWb = oXLApp.Workbooks.Open(ActivePresentation.Path & "\" & "Property Wide.xlsm")
'Shifts
Set Shifts = oWb.Sheets(4).Range("A1:A" & lastRow(oWb.Sheets(4), "a"))
'departments
Set Deps = oWb.Sheets(3).Range("A1:" & Chr(lastColumn(oWb.Sheets(3), "1") + 64) & "1")
'supervisors
End Sub
Public Function lastRow(ByVal SheetA As Worksheet, Optional Columnno As String = "/") As Long
If (Columnno = "/") Then
Set lastRow = SheetA.UsedRange.Row - 1 + SheetA.UsedRange.Rows.Count
Else
Set lastRow = SheetA.Range(Columno & Rows.Count).End(xlUp).Row
End If
End Function
Public Function lastColumn(ByVal SheetA As Worksheet, Optional rowno As String = "/") As Integer
If (rowno = "/") Then
Set lastColumn = SheetA.UsedRange.Column - 1 + SheetA.UsedRange.Columns.Count
Else
Set lastColumn = SheetA.Cells(rowno, Columns.Count).End(xlToLeft).Column
End If
End Function
With that you should have what you need.