I have an existing VBA Project that I simply need to modify even if does scream to be re-written one day.
The sheet has a hidden sheet called Options that lists a file path in B3 and that path is called \fileserver\Drafting\MBS_JOBS\
The code then assigns a variable this path:
strpathtofile = Sheets("Options").Range("B3").Value
Finally, later on, it puts it all together with this:
strFileToOpen = strpathtofile & ActiveCell.Value & strFilename
What I need to do now is have it check a second path. So I've duplicated some of the code.
I first put the new path in B7 of the OPTIONS page. Then, I created a variable and assigned it:
Public strpathtoProj As String
strpathtoProj = Sheets("Options").Range("B7").Value
So, what I need to do is have this program also check this other path. So wondering if I need some kind of IF, THEN or ELSE statement around this part:
strFileToOpen = strpathtofile & ActiveCell.Value & strFilename
To also make it look at strpathtoProj.
I'm a "work in progress" VBA developer as a SOLO IT guy for a small business and am learning as I go.
Here are the modules that use strpathtofile (and you can see that I've already got some code in there for the strpathtoProj that I now need to use):
Sub RUN_SUMMARY_REPORT()
'assign variable... this is here just in case they haven't ran the "TEST" button
strpathtofile = Sheets("Options").Range("B3").Value
strFilename = Sheets("Options").Range("B4").Value
strThisBook = Sheets("Options").Range("B5").Value
strExtraInformation = Sheets("Options").Range("B6").Value
strpathtoProj = Sheets("Options").Range("B7").Value
'assign variable... this is here just in case they haven't ran the "TEST" button
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveSheet.Unprotect
'Remove any past data
SHOW_WARNING (False)
' Extended The Range To Remove data that continued below line 44. Brian
1/20/2015
' Range("C2:C200").ClearContents ' Jobs
Range("F4:S13").ClearContents ' Bar
Range("G17:G23").ClearContents ' Web Plate
Range("J17:J19").ClearContents ' Cable
Range("M17:M23").ClearContents ' Rod
Range("P17:P25").ClearContents ' Angle
'Remove any past data
'initialize ExtraInformation
Sheets(strExtraInformation).Range("A1:K1000").ClearContents
Sheets(strExtraInformation).Select
Range("A1").Select
'initialize ExtraInformation
SHOW_SHEETS (True)
INITIALIZE_PUBLIC_VARS
IMPORT_ALL_INFORMATION
PRINT_WEB_DATA
PRINT_BAR_DATA
PRINT_BRAC_DATA
PRINT_ROD_DATA
PRINT_ANGLE_DATA
SHOW_SHEETS (False)
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Sub TEST_FOR_BAD_JOB_MUMBERS()
Dim bFound As Boolean
On Error GoTo EXPLAIN
Application.ScreenUpdating = False 'increase performance
Application.DisplayAlerts = False
'Unhide all sheets
Sheets("REPORT").Visible = True
'Unhide all sheets
'Get all of the settings for this macro and assign variables
strpathtofile = Sheets("Options").Range("B3").Value
strFilename = Sheets("Options").Range("B4").Value
strpathtoProj = Sheets("Options").Range("B7").Value
'Get all of the settings for this macro and assign variables
Sheets("REPORT").Select
ActiveSheet.Unprotect
Range("C2").Select
Do Until ActiveCell.Value = ""
bFound = True
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject") 'Wow! What an
efficiency increase!
If Not fso.FileExists(strpathtofile & ActiveCell & strFilename) Then 'Wow!
What an efficiency increase!
Error (53) 'file not found error
End If
ActiveCell.Font.Color = RGB(0, 0, 0)
ActiveCell.Font.Bold = False
ActiveCell.Offset(1, 0).Select
Loop
Range("c2").Select
'Clean up the look of this thing!
Sheets("Options").Visible = False
Sheets("REPORT").Select
If bFound Then
MsgBox "Test Has Passed! All Job Numbers Found on X-Drive"
Else
MsgBox "No Jobs!"
End If
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Exit Sub
EXPLAIN:
'Clean up the look of this thing!
Sheets("Options").Visible = False
Sheets("REPORT").Select
ActiveCell.Font.Color = RGB(255, 0, 0)
ActiveCell.Font.Bold = True
MsgBox "One Or More Jobs Do Not Exist. Please Check for RED Highlighted
Job."
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Sub IMPORT_ALL_INFORMATION()
'Set variables
Dim file_in As Long
Dim strInput As Variant
'end setting variables
Sheets("REPORT").Select
Range("C2").Select
Do Until ActiveCell.Value = "" '//loop through each job
file_in = FreeFile 'next file number
strFileToOpen = strpathtofile & ActiveCell.Value & strFilename
Open strFileToOpen For Input As #file_in
Put_Data_In_Array (file_in)
Organize_Array_For_Print
Close #file_in ' close the file
file_in = file_in + 1
Sheets("REPORT").Select
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Judging by the title of your question this is what you need, but I am a little confused by your question:
sub MainSub()
FileOne = worksheets("SuperSecretHiddenSheet").range("A1").value
FileTwo = worksheets("SuperSecretHiddenSheet").range("A2").value
if bothfileExists(FileOne, FileTwo) = true then
'do stuff
end if
End Sub
function bothfileExists(ByRef FileOne as string, ByRef fileTwo as string) as boolean
if (dir(fileone) <> "" and dir(fileTwo) <> "") then
bothfileExists = True
else
bothfileExists = False
end if
end function
Related
I have created a macro where I download data into Excel from a software database through an array formula. The scope of the macro is to input a start date and the data is written to individual Excel files and then saved away.
Unfortunately the macro is very slow although I am using the usual code lines to speed up the macro.
Another problem is that the array formula constantly expands the UsedRange with empty lines and thus the file gets bigger and bigger. To counteract this, I delete the empty lines within a For Next loop. Last but not least I still have screen flickering. My guess is the use of DoEvents but I need it for the update of the array formula.Otherwise the code will continue without having the data downloaded.
Below is my code:
Sub Update()
Dim wbTarget As Workbook
Dim objWsInput As Worksheet, objWsMakro As Worksheet, objWsDerivative, objWsFile
Dim Inbox1 As Variant
Dim strFormula As String, strFilename As String, strDate As String
Dim lngDate As Long
Dim dDay As Date
Set objWsInput = ThisWorkbook.Worksheets("INPUT")
'Input start date
Inbox1 = InputBox("Geben Sie bitte ein Start-Datum ein!", Default:=Format(Date, "DD.MM.YYYY"))
Call EventsOff
For dDay = DateSerial(Year(Inbox1), Month(Inbox1), Day(Inbox1)) To DateSerial(Year(Now), Month(Now), Day(Now))
If Weekday(dDay) <> 1 And Weekday(dDay) <> 7 Then
'Convert date into DateValue & string
strDate = Format(dDay, "YYYYMMDD")
lngDate = DateValue(dDay)
'Delete contents
With objWsInput
.Activate
.UsedRange.ClearContents
'Set array formula for QPLIX
strFormula = "=DisplayAllocationWithPreset(""5a9eb7ae2c94dee7a0d0fd5c"", ""5b06a1832c94de73b4194ccd"", " & lngDate & ")"
.Range("A1").FormulaArray = strFormula
'Wait until refresh is done
Do
DoEvents
Loop While Not Application.CalculationState = xlDone
'Copy paste
.Range("A1").CurrentRegion.Copy
.Range("A1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Call last row and delete depth 0 with number format
i = 2
Call LastRow
For i = CountRow To 2 Step -1
If .Cells(i, 1) = 0 Then .Rows(i).Delete
Next i
Call NumberFormat
'Set file name
strFilename = "Y:\Risikomanagement\Mandate Positions\QPLIX_Mandate_Positions_" & strDate & ".xlsx"
'Open file
Set wbTarget = Workbooks.Add
Set objWsFile = wbTarget.Worksheets(1)
'Copy data into new file
.Range("C1:J" & .Range("A1").CurrentRegion.Rows.Count).Copy Destination:=objWsFile.Range("A1")
'Save file
wbTarget.SaveAs Filename:=strFilename
wbTarget.Close
Call DeleteBlankRows
End With
End If
Next dDay
'Save Workbook
ActiveWorkbook.Save
Call EventsOn
MsgBox "Upload Files erstellt!", vbInformation, "Hinweis"
End Sub
The support functions are as followed:
Public Sub EventsOff()
'Events ausschalten
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
End Sub
Public Sub EventsOn()
'Events anschalten
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Sub
To complete my code here are the parts for deleting empty rows & formatting the numbers:
Sub DeleteBlankRows()
Dim MyRange As Range
Dim iCounter As Long
Set MyRange = ActiveSheet.UsedRange
For iCounter = MyRange.Rows.Count To 1 Step -1
'Step 4: If entire row is empty then delete it.
If Application.CountA(Rows(iCounter).EntireRow) = 0 Then
Rows(iCounter).Delete
End If
Next iCounter
End Sub
Sub NumberFormat()
Dim r As Range
For Each r In ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)
If IsNumeric(r) Then
r.Value = CDec(r.Value)
r.NumberFormat = "#,##0.00"
End If
Next r
End Sub
Any help is appreciated.Thank you in advance.
Rgds
It seems that DoEvents disables the usual speed up procedures like:
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
I changed my code including the support function Call Events Off directly after DoEvents loop and the flickering disappeared. The whole process was also much faster.
I have a xl file with about 2000 rows and columns from A to H. I was trying to sort the file based on the column D such that all other columns are also sorted accordingly (expand selection area).
I am very new to Macros and have been doing this small task to save some time on my reporting.
Here's what I tried:
Prompt the user to select a file
Set the columns from A to H
Sort Range as D2
Save the file
As I said, I am new, I have used much of the code from sample examples in the MSDN library. Apart from Sort(), every thing else is working for me.
here's the code
Sub Select_File_Windows()
Dim SaveDriveDir As String
Dim MyPath As String
Dim Fname As Variant
Dim N As Long
Dim FnameInLoop As String
Dim mybook As Workbook
Dim SHEETNAME As String
'Default Sheet Name
SHEETNAME = "Sheet1"
' Save the current directory.
SaveDriveDir = CurDir
' Set the path to the folder that you want to open.
MyPath = Application.DefaultFilePath
' Open GetOpenFilename with the file filters.
Fname = Application.GetOpenFilename( _
FileFilter:="XLS Files (*.xls),*.xls,XLSX Files (*.xlsx),*.xlsx", _
Title:="Select a file", _
MultiSelect:=True)
' Perform some action with the files you selected.
If IsArray(Fname) Then
With Application
.ScreenUpdating = False
.EnableEvents = True
End With
For N = LBound(Fname) To UBound(Fname)
' Get only the file name and test to see if it is open.
FnameInLoop = Right(Fname(N), Len(Fname(N)) - InStrRev(Fname(N), Application.PathSeparator, , 1))
If bIsBookOpen(FnameInLoop) = False Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(Fname(N))
On Error GoTo 0
DoEvents
If Not mybook Is Nothing Then
Debug.Print "You opened this file : " & Fname(N) & vbNewLine
With mybook.Sheets(SHEETNAME)
'Columns("A:H").Sort Key1:=Range("D2:D2000"), Order1:=xlAscending, Header:=xlYes
'Range("A1:H2000").Sort Key1:=Range("D1"), Order1:=xlAscending
Columns("A:H").Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes
End With
Debug.Print "Sorter Called"
mybook.Close SaveChanges:=True
End If
Else
Debug.Print "We skipped this file : " & Fname(N) & " because it is already open. Please close the data file and try again"
End If
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Nothing is working for me. The file stays as is and No update is made to it. I could not understand, what is the newbie mistake I have been making here ?
Please help.
References:
https://msdn.microsoft.com/en-us/library/office/ff840646(v=office.15).aspx
http://analysistabs.com/vba/sort-data-ascending-order-excel-example-macro-code/
Run time error 1004 when trying to sort data on three different values
It may be as simple as adding a couple of dots (see pentultimate line below)
With mybook.Sheets(SHEETNAME)
'Columns("A:H").Sort Key1:=Range("D2:D2000"), Order1:=xlAscending, Header:=xlYes
'Range("A1:H2000").Sort Key1:=Range("D1"), Order1:=xlAscending
.Columns("A:H").Sort Key1:=.Range("D1"), Order1:=xlAscending, Header:=xlYes
End With
SJR is correct in saying that your references should be fully qualified inside of the With Statement.
You should simplify your subroutines by extracting large blocks of code into separate subroutines. The fewer tasks that a subroutines handles, the easier it is to read and to debug.
Refactored Code
Sub Select_File_Windows()
Const SHEETNAME As String = "Sheet1"
Dim arExcelFiles
Dim x As Long
arExcelFiles = getExcelFileArray
If UBound(arExcelFiles) = -1 Then
Debug.Print "No Files Selected"
Else
ToggleEvents False
For x = LBound(arExcelFiles) To UBound(arExcelFiles)
If IsWorkbookOpen(arExcelFiles(x)) Then
Debug.Print "File Skipped: "; arExcelFiles(x)
Else
Debug.Print "File Sorted: "; arExcelFiles(x)
With Workbooks.Open(arExcelFiles(x))
With .Sheets(SHEETNAME)
.Columns("A:H").Sort Key1:=.Range("D1"), Order1:=xlAscending, Header:=xlYes
End With
.Close SaveChanges:=True
End With
End If
Next
ToggleEvents True
End If
End Sub
Function IsWorkbookOpen(ByRef szBookName As String) As Boolean
On Error Resume Next
IsWorkbookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Function getExcelFileArray()
Dim result
result = Application.GetOpenFilename( _
FileFilter:="Excel Workbooks, *.xls; *.xlsx", _
Title:="Select a file", _
MultiSelect:=True)
If IsArray(result) Then
getExcelFileArray = result
Else
getExcelFileArray = Array()
End If
End Function
Sub ToggleEvents(EnableEvents As Boolean)
With Application
.ScreenUpdating = EnableEvents
.Calculation = IIf(EnableEvents, xlCalculationAutomatic, xlCalculationManual)
.EnableEvents = EnableEvents
End With
End Sub
I want to protect all the sheets in a workbook based on username, so workbooks will be protected from external use, whereas internally we can easily use. However, the code just always states that the line If ws.Protect = True Then is false, even when I know the sheet is protected...
Private Sub Workbook_Open()
Dim strUser, Num, myCount, ws
strUser = CreateObject("WScript.Network").UserName
strUser = LCase(strUser)
Num = CLng(Right(strUser, 6))
If Left(strUser, 1) = "D" And Len(strUser) = 11 And IsNumeric(Num) Then
For Each ws In ActiveWorkbook.Worksheets
If ws.Protect = True Then
ws.Unprotect "password"
Else
ws.Protect "password", DrawingObjects:=True, Contents:=True, _
AllowSorting:=True, AllowFiltering:=True
End If
Next ws
End If
End Sub
any help would be appreciated!
You need to look at the ProtectContents property, so
If ws.Protect = True Then should be If ws.ProtectContents = True Then
ws.protect is the command to protect the sheet not check if its protected. You can use
ActiveSheet.ProtectContents
ActiveSheet.ProtectDrawingObjects
activeSheet.ProtectScenarios
in your if statements to check if the sheet is protected in any combination of these properties.
Look here for more info:
https://support.microsoft.com/en-us/kb/161245
I just want to comment that your user name checking code seems like it will fail a lot:
Num = CLng(Right(strUser, 6)) this will give error if strUser does not end with 6 digits.
What you want is IsNumeric( Right(strUser, 6) )
Actually, dont even use IsNumeric because for example IsNumeric("1,234.56") will return True.
Left(strUser, 1) = "D" this will be False because you convert the strUset to lower case with strUser = LCase(strUser) (unless you have Option Compare Text in the begining of the file)
You can shorten the check to
Private Sub Workbook_Open()
Dim strUser$, ws As Worksheet
strUser = Environ$("UserName")
If Not strUser Like "[Dd]????######" Then Exit Sub ' ? matches any character, # matches any digit from 0 to 9, and [Dd] matches upper or lower case D
For Each ws In ActiveWorkbook.Worksheets
If ws.ProtectContents = True Then
ws.Unprotect "password"
Else
ws.Protect "password", DrawingObjects:=True, Contents:=True, _
AllowSorting:=True, AllowFiltering:=True
End If
Next ws
End Sub
I have this consolidation macro which opens, copies and pastes data from one sheet of several workbooks onto a master sheet where such data as well as workbooks maybe in the thousands. Overall this process will take anywhere from 30mins to an hour and I thought a progress bar would help.
I got the code i used for the consolidation part here at stackoverflow. It was somebody with a similar issue, however, the progress bar code i got somewhere else. I had to jury-rig the code of sorts to fit it for my needs.. The examples online uses a for next loop code for the progress bar which mine doesn't.
i tried running my code but the progress bar doesn't update.. T_T
can somebody help me with what's wrong with my code?
Any help on this is very much appreciated.. thanks..
Sub OpeningFiles()
Dim SelectedFiles As FileDialog
Dim NumFiles As Long, FileIndex As Long
Dim TargetBook As Workbook
Dim sName, sName2, sName3 As Range
Dim pctCompl As Single
Set sName = ThisWorkbook.Sheets("Sheet1").Range("j1")
Set SelectedFiles = Application.FileDialog(msoFileDialogOpen)
With SelectedFiles
.AllowMultiSelect = True
.Title = "Pick the files you'd like to consolidate:"
.ButtonName = ""
.Filters.Clear
.Filters.Add ".xlsx files", "*.xlsx"
.Show
End With
If SelectedFiles.SelectedItems.Count = 0 Then Exit Sub
NumFiles = SelectedFiles.SelectedItems.Count
For FileIndex = 1 To NumFiles
Set TargetBook = Workbooks.Open(SelectedFiles.SelectedItems(FileIndex), ReadOnly:=True)
Application.DisplayAlerts = False
ActiveWorkbook.Activate
Sheets(sName).Activate
On Error GoTo 0
Range("d11:j11").Select
Range(Selection, Selection.End(xlDown)).Copy
ThisWorkbook.Sheets("Sheet1").Activate
Range("b2").Select
Do
If IsEmpty(ActiveCell) = False Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until IsEmpty(ActiveCell) = True
ActiveCell.PasteSpecial Paste:=xlPasteValues
ThisWorkbook.Application.CutCopyMode = False
TargetBook.Close SaveChanges:=False
Next FileIndex
progress pctCompl
MsgBox ("Consolidation complete!")
End Sub
Sub progress(pctCompl As Single)
UserForm1.Text.Caption = pctCompl & "% Completed"
UserForm1.Bar.Width = pctCompl * 2
DoEvents
End Sub
Sub ShowProgress()
UserForm1.Show
End Sub
Addendum:
This code
Sheets(sName).activate
selects the sheetname of the opened file wherein it is always a number from 1-30. Right now, I have to indicate that number one at a time. Is there a way to do it like 3 or 7 times? like a loop? e.g 1-7 or 25-27.. It is always ascending so i thought a code like the one below will work? Thoughts?
For sName = sNameStart To sNameEnd Step 1
Sheets(sName).Activate
On Error GoTo 0
Range("d11:j11").Select
Range(Selection, Selection.End(xlDown)).Copy
ThisWorkbook.Sheets("Sheet1").Activate
Range("b2").Select
Do
If IsEmpty(ActiveCell) = False Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until IsEmpty(ActiveCell) = True
ActiveCell.PasteSpecial Paste:=xlPasteValues
ActiveWorkbook.Activate
Next sName
where sName is the sheet name, sNameStart is the start sheet and sNameEnd is the end sheet.
However, i get this error when I start this code.. Help?
You need to move your call to progress pctCompl inside your loop.
The code you posted doesn't call progress pctCompl until after Next FileIndex
ThisWorkbook.Application.CutCopyMode = False
TargetBook.Close SaveChanges:=False
Next FileIndex
progress pctCompl
MsgBox ("Consolidation complete!")
Replace it with this:
ThisWorkbook.Application.CutCopyMode = False
TargetBook.Close SaveChanges:=False
'insert your command here
progress pctCompl
Next FileIndex
MsgBox ("Consolidation complete!")
If you need something more precise than progress bar try putting:
Application.StatusBar = "File " & FileIndex & " of " & NumFiles
somewhere within For..Next loop, I like this because it is more verbose than just progress bar.
And remember to put
Application.StatusBar = False
After your loop to restore standard status bar.
I'm a beginner with VBA and I'm wondering how to add a IF ELSE statement to my code:
I only want to enable to copy the cells if the are filled and if they are not filled msgbox must pop-up
code:
Private Sub CommandButton3_Click()
Application.ScreenUpdating = False
Dim NextRow As Range
Sheet1.Range("F7,F10,F13,F16,F19,F22,F25,F28").Copy
Sheets("Overzicht").Select
Set NextRow = ActiveSheet.Cells(Cells.Rows.Count, 1).End(xlUp).Offset(1, 0)
NextRow.Select
Selection.PasteSpecial (xlValues), Transpose:=True
MsgBox "Invoer is opgeslagen"
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Welcome to stackoverflow.com
You have to wrap your copy code block with a for loop, IF-ELSE statement and a Boolean type variable.
Firstly, you want to iterate over your specified range of cells and make sure they are all filled
Dim allFilled As Boolean
Dim i As Long
For i = 7 To 28 Step 3
If Not IsEmpty(Sheet1.Range("F" & i)) Then
allFilled = True
Else
allFilled = False
End If
Next i
If they are you can proceed with copying-pasting and if they are not the program will show a message box: Not all the cells are filled! Cant copy
your complete code:
Sub CommandButton3_Click()
Application.ScreenUpdating = False
Dim allFilled As Boolean
Dim i As Long
For i = 7 To 28 Step 3
If Not IsEmpty(Sheet1.Range("F" & i)) Then
allFilled = True
Else
allFilled = False
End If
Next i
If allFilled Then ' = if (allFilled = true) then
Dim NextRow As Range
Sheet1.Range("F7,F10,F13,F16,F19,F22,F25,F28").Copy
Sheets("Overzicht").Select
Set NextRow = ActiveSheet.Cells(Cells.Rows.Count, 1).End(xlUp). _
Offset(1, 0)
NextRow.Select
Selection.PasteSpecial (xlValues), Transpose:=True
MsgBox "Invoer is opgeslagen"
Application.CutCopyMode = False
Application.ScreenUpdating = True
Else
MsgBox "Not all the cells are filled! Cant copy"
End If
End Sub
Update, from comments:
Yes, it's possible to execute different checks individually too, for example:
Dim allFilled As Boolean
If Not IsEmpty(Range("F7, F10, F13, F16")) And IsEmpty(Range("F8")) Then
' F7, F10, F13, F16 are not empty and F8 is empty
allFilled = True
ElseIf IsEmpty(Range("F28")) Then
' F28 empty cannot execute copy-paste
allFilled = False
Else
allFilled = False
End If