I made a Commandbutton that will allow the user to save the file based on the values within the excel cells in which the cells are pre-populated to begin with. Also how do you implement this fuction GetSaveAsFilename so the user can choose a save destination but not change the title. But I am getting an error executing this code.
Private Sub CommandButton2_Click()
Sub SaveMyWorkbook()
Dim strPath As String
Dim strFolderPath As String
strFolderPath = "C:\Users\"
strPath = strFolderPath & _
DoNotPrint - Setup.Range("C7").Value & " " & _
DoNotPrint - Setup.Range("C8").Value & " " & _
DoNotPrint - Setup.Range("C45").Value & " " & _
DoNotPrint - Setup.Range("C9").Value & ".xlsm"
End Sub
Best guess:
With Thisworkbook.sheets("DoNotPrint - Setup")
strPath = strFolderPath & .Range("C7").Value & " " & _
.Range("C8").Value & " " & _
.Range("C45").Value & " " & _
.Range("C9").Value & ".xlsm"
End with
Selecting a folder to save to:
VBA EXCEL To Prompt User Response to Select Folder and Return the Path as String Variable
To allow the user to choose the folder I use this:
Private Sub CommandButton2_Click()
Dim strPath As String
Dim strFolderPath As String
strFolderPath = "C:\Users\"
strPath = strFolderPath & _
DoNotPrint - Setup.Range("C7").Value & " " & _
DoNotPrint - Setup.Range("C8").Value & " " & _
DoNotPrint - Setup.Range("C45").Value & " " & _
DoNotPrint - Setup.Range("C9").Value & ".xlsm"
With Application.FileDialog(msoFileDialogSaveAs)
.AllowMultiSelect = False
.InitialFileName = strPath
.FilterIndex = 2
.Title = Place Title Here if you want
If .Show = -1 Then .Execute
End With
End Sub
Based on Tim's and Zack's Answer, this worked
Private Sub CommandButton2_Click()
Dim strPath As String
Dim strFolderPath As String
strFolderPath = "C:\Users\"
With ThisWorkbook.Sheets("DoNotPrint - Setup")
strPath = strFolderPath & .Range("C7").Value & " " & _
.Range("C8").Value & " " & _
.Range("C45").Value & " " & _
.Range("C9").Value & ".xlsm"
End With
With Application.FileDialog(msoFileDialogSaveAs)
.AllowMultiSelect = False
.InitialFileName = strPath
.FilterIndex = 2
If .Show = -1 Then .Execute
End With
End Sub
Related
I've written a spreadsheet for a small company, that has several useful functions including performing the shift rotation for their full- and part-time employees, generates a list of possibly understaffed shifts and then prompts the user to save the updated file with a suggested new name. However I code it, I run into one of 2 problems:
The macro is able to save the spreadsheet without the macros - but then subsequent adjustments to the scheduling won't be reflected in the list of understaffed shifts because the macro isn't saved with the file.
The macro attempts to save the spreadsheet with the macros - but returns an error message, regardless of the parameters I pass the Workbook.SaveAs method. I would have expected that if I saved it with FileFormat=xlOpenXMLWorkbookMacroEnabled and a .xlsm suffix, then there'd be no problem. Instead I get an error message (sorry I don't have it in front of me) to the effect that Excel can't save the spreadsheet in that format. If I manually save the spreadsheet in that format, I have no problem.
I suspect this has to do with safeguards against VBA viruses, but I'm not sure how else to create the functionality I need. The office staff are not computer professionals by any stretch of the imagination, so I need to keep it simple. We also need a record of past rotations, so staff can look back on previous adjustments. At the same time, they want to be able to make adjustments to the current rotation and then re-generate the list of understaffed shifts, or clear it and start again.
I've checked similar forums and posts and the thing that usually does the trick, making sure the filename suffix is in line with the FileType parameter, doesn't seem to have worked here. Any suggestions?
Public Sub SaveSchedule()
Dim SaveName As String
Dim SaveDlg As Office.FileDialog
With Excel.ActiveWorkbook.Worksheets("Workers")
SaveName = "Shift Schedule " & Year(.Range("StartDate"))
SaveName = SaveName & "-" & Right("00" & Month(.Range("StartDate")), 2)
SaveName = SaveName & "-" & Right("00" & Day(.Range("StartDate")), 2)
SaveName = SaveName & " to " & Year(.Range("EndDate"))
SaveName = SaveName & "-" & Right("00" & Month(.Range("EndDate")), 2)
SaveName = SaveName & "-" & Right("00" & Day(.Range("EndDate")), 2)
SaveName = SaveName & ".xlsm" '".xlsx"
End With
Set SaveDlg = Application.FileDialog(msoFileDialogSaveAs)
With SaveDlg
.AllowMultiSelect = False
.ButtonName = "Save"
.InitialFileName = SaveName
.Title = "Save new shift schedule"
If .Show() Then
Excel.ActiveWorkbook.SaveAs .SelectedItems(1), xlOpenXMLWorkbookMacroEnabled ' xlOpenXMLWorkbook
Else
MsgBox SaveName & " should be saved as a new file.", vbCritical + vbApplicationModal + vbOKOnly, "New Schedule not saved."
End If
End With
End Sub
The issue with Application.FileDialog(msoFileDialogSaveAs) is that if you do not specify a correct filter index then it will either pick the first one
OR the one which was used last. This can be resolved by specifying .FilterIndex. For .xlsm. the filter index is 2.
Try this
With SaveDlg
.AllowMultiSelect = False
.ButtonName = "Save"
.InitialFileName = SaveName
.FilterIndex = 2 '<~~ FILTER INDEX
.Title = "Save new shift schedule"
If .Show() Then
Excel.ActiveWorkbook.SaveAs .SelectedItems(1), xlOpenXMLWorkbookMacroEnabled ' xlOpenXMLWorkbook
Else
MsgBox SaveName & " should be saved as a new file.", vbCritical + vbApplicationModal + vbOKOnly, "New Schedule not saved."
End If
End With
OTHER OPTIONS
OPTION 1 : Directly save the file
Dim SaveName As String
With Excel.ActiveWorkbook.Worksheets("Workers")
SaveName = "Shift Schedule " & Year(.Range("StartDate"))
SaveName = SaveName & "-" & Right("00" & Month(.Range("StartDate")), 2)
SaveName = SaveName & "-" & Right("00" & Day(.Range("StartDate")), 2)
SaveName = SaveName & " to " & Year(.Range("EndDate"))
SaveName = SaveName & "-" & Right("00" & Month(.Range("EndDate")), 2)
SaveName = SaveName & "-" & Right("00" & Day(.Range("EndDate")), 2)
SaveName = SaveName & ".xlsm" '".xlsx"
End With
Excel.ActiveWorkbook.SaveAs Filename:=SaveName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
OPTION 2 : Let user only choose a folder
In this option user will not be able to modify the file name and extension. They can only choose the Save As folder.
Option Explicit
Sub Sample()
Dim SaveName As String
Dim Extn As String
Dim FlFormat As Integer
With Excel.ActiveWorkbook.Worksheets("Workers")
SaveName = "Shift Schedule " & Year(.Range("StartDate"))
SaveName = SaveName & "-" & Right("00" & Month(.Range("StartDate")), 2)
SaveName = SaveName & "-" & Right("00" & Day(.Range("StartDate")), 2)
SaveName = SaveName & " to " & Year(.Range("EndDate"))
SaveName = SaveName & "-" & Right("00" & Month(.Range("EndDate")), 2)
SaveName = SaveName & "-" & Right("00" & Day(.Range("EndDate")), 2)
SaveName = SaveName
End With
'~~> File extenstion. I have shown only for 2
'~~> Tweak for rest
Extn = ".xlsm" '".xlsx"
If Extn = ".xlsm" Then
FlFormat = xlOpenXMLWorkbookMacroEnabled
ElseIf Extn = ".xlsx" Then
FlFormat = xlOpenXMLWorkbook
End If
'~~> Folder Browser
Dim Ret As Variant
Ret = BrowseForFolder
If Ret = False Then Exit Sub
Dim Filepath As String
Filepath = Ret
If Right(Filepath, 1) <> "\" Then Filepath = Filepath & "\"
SaveName = Filepath & SaveName & Extn
Excel.ActiveWorkbook.SaveAs Filename:=SaveName, FileFormat:=FlFormat
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo CleanExit
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo CleanExit
Case Else
GoTo CleanExit
End Select
Exit Function
CleanExit:
BrowseForFolder = False
End Function
SaveAs Dialog
Public Sub SaveSchedule()
Const PROC_TITLE As String = "Save New Shift Schedule"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Workers")
Dim SaveName As String
With ws
SaveName = "Shift Schedule " & Format(.Range("StartDate"), "YYYY-MM-DD")
SaveName = SaveName & " to " & Format(.Range("EndDate"), "YYYY-MM-DD")
SaveName = SaveName & ".xlsm"
End With
Dim SaveDlg As Office.FileDialog
Set SaveDlg = Application.FileDialog(msoFileDialogSaveAs)
With SaveDlg
.AllowMultiSelect = False
.ButtonName = "SaveAs"
.FilterIndex = 2 ' .xlsm
.InitialFileName = SaveName
.Title = PROC_TITLE
Dim FilePath As String
If .Show Then
FilePath = .SelectedItems(1)
If StrComp(Right(FilePath, 5), ".xlsm", vbTextCompare) = 0 Then
Application.DisplayAlerts = False ' overwrite, no confirmation
wb.SaveAs FilePath, xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = True
Else ' not '.xlsm'
MsgBox "The file needs to be saved with an '.xlsm' extension." _
& vbLf & "File not saved.", _
vbCritical + vbApplicationModal, PROC_TITLE
End If
Else ' canceled
MsgBox SaveName & " not saved.", _
vbCritical + vbApplicationModal, PROC_TITLE
End If
End With
End Sub
So i have found 2 macros which i want to use to save and create a back up files for the said file.
The Macro which i want to primarily use is this one:
Sub DateFolderSave()
Dim strGenericFilePath As String: strGenericFilePath = "D:\"
Dim strYear As String: strYear = Year(Date) & "\"
Dim strMonth As String: strMonth = MonthName(Month(Date)) & "\"
Dim strDay As String: strDay = Day(Date) & "\"
Dim strFileName As String: strFileName = "_Dispatch Process_"
Application.DisplayAlerts = False
' Check for year folder and create if needed
If Len(Dir(strGenericFilePath & strYear, vbDirectory)) = 0 Then
MkDir strGenericFilePath & strYear
End If
' Check for month folder and create if needed
If Len(Dir(strGenericFilePath & strYear & strMonth, vbDirectory)) = 0 Then
MkDir strGenericFilePath & strYear & strMonth
End If
' Check for date folder and create if needed
If Len(Dir(strGenericFilePath & strYear & strMonth & strDay, vbDirectory)) = 0 Then
MkDir strGenericFilePath & strYear & strMonth & strDay
End If
' Save File
ActiveWorkbook.SaveAs FileName:= _
strGenericFilePath & strYear & strMonth & strDay & strFileName, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Application.DisplayAlerts = True
' Popup Message
MsgBox "File Saved As: " & vbNewLine & strGenericFilePath & strYear & strMonth & strDay & strFileName
End Sub
So i found this another Macro which make continuous back up of the files and has a custom format to a file name
Sub Save_Backup(ByVal Backup_Folder_Path As String)
Dim fso As Object
Dim ExtensionName As String, FileName As String
Dim wbSource As Workbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set wbSource = ThisWorkbook
ExtensionName = fso.GetExtensionName(wbSource.Name)
FileName = Replace(wbSource.Name, "." & ExtensionName, "")
fso.CopyFile ThisWorkbook.FullName, _
fso.BuildPath(Backup_Folder_Path, FileName & " (" & Format(Now(), "dd-mmm-yy hh.mm AM/PM") & ")." & ExtensionName)
Set fso = Nothing
Set wbSource = Nothing
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Call Save_Backup("C:\Users\admin\Downloads\Back Up\New Backup")
End Sub
So i want to create back up like the first macro(i.e. Folder inside a folders for the specific date) but want to have a continuous stream of files for back up(i.e. Want the date folder to create new save file each time i save the Document)
Is there a way to combine both these macros?
I have a macro in an Excel Workbook, that is connected to a button that says Export
When I click the button, it triggers the Export XML dialog and I have to manually search for a folder to export it into and enter the filename.
Since the folders in my Documents are named exactly the same as the value of the Cell A24, i would like it to direct itself into the correct folder and suggest me a filename based on the value of the Cell A24 with some extra text behind it.
So far i have this in the VBA:
Public Sub ExportToXML()
Dim strFilePath As String
Dim POFilePath As String
Dim FOFilePath As String
Dim POFileName As String
Dim FOFileName As String
Dim XMLDoc As MSXML2.DOMDocument
Dim xNode As MSXML2.IXMLDOMNode
Dim xAttribute As MSXML2.IXMLDOMAttribute
Dim xElement As MSXML2.IXMLDOMElement
Dim xElementRoot As MSXML2.IXMLDOMElement
Application.ScreenUpdating = False
MainSheetName = ActiveSheet.Name
POFilePath = "C:\Users\admin\Desktop\" & Range("A24")
FOFilePath = "C:\Users\admin\Desktop\" & Range("D22") & " " & Range("A22")
POFileName = "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
FOFileName = "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
If Range("A24").value = "0" Then
strFilePath = Application.GetSaveAsFilename(FOFilePath & FOFileName, fileFilter:="XML files (*.xml),*.xml", Title:="Save FileAs...")
Else
strFilePath = Application.GetSaveAsFilename(POFilePath & POFileName, fileFilter:="XML files (*.xml),*.xml", Title:="Save FileAs...")
End If
If strFilePath = "False" Then Exit Sub
This gives me the right filename suggestion, but it doesn't direct me to the folder and goes to Desktop.
Any help would be appriciated!
EDIT:
I tried merging the Strings together a bit more and came up with this:
Public Sub ExportToXML()
Dim strFilePath As String
Dim POFilePath As String
Dim FOFilePath As String
Dim XMLDoc As MSXML2.DOMDocument
Dim xNode As MSXML2.IXMLDOMNode
Dim xAttribute As MSXML2.IXMLDOMAttribute
Dim xElement As MSXML2.IXMLDOMElement
Dim xElementRoot As MSXML2.IXMLDOMElement
Application.ScreenUpdating = False
MainSheetName = ActiveSheet.Name
POFilePath = "C:\Users\admin\Desktop\" & Range("A24") & Range("A24").value & "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
FOFilePath = "C:\Users\admin\Desktop\" & Range("D22") & " " & Range("A22") & "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
If Range("A24").value = "0" Then
strFilePath = Application.GetSaveAsFilename(FOFilePath, fileFilter:="XML files (*.xml),*.xml", Title:="Save FileAs...")
Else
strFilePath = Application.GetSaveAsFilename(POFilePath, fileFilter:="XML files (*.xml),*.xml", Title:="Save FileAs...")
End If
If strFilePath = "False" Then Exit Sub
The problem is, that VBA thinks that in:
POFilePath = "C:\Users\admin\Desktop\" & Range("A24") & Range("A24").value & "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
the first Range("A24") belongs to the filename part and doesn't continue on with the filepath. So if the value in A24 was "test", then this suggests saving the xml to Desktop with the filename testttest_report 11 2020
i need a modification in this code to suppress save as dialogbox(save file as pdf in mentioned location (C:\Users\hazem\Desktop\New folder (4)\HM\PDF) without any save as screen appears and without excel workbook name changed)_
note :_
i work on windows 10 ,excel ver. 2019
this code is part of macro
(Application.DisplayAlerts = False _
""code between""_
Application.DisplayAlerts = true)
doesn't work with me
This is the code:
Sub PDFActiveSheet()
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim MyFile As Variant
Dim answer As Integer
Dim fnd As Variant
Dim rplc As Variant
Filename1 = Range("B4")
filename2 = Range("G11")
filename3 = Range("M4")
filename4 = Range("B4")
filename5 = Range("B5")
filename6 = Range("C5")
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyy-mm-dd_hhmm")
strPath = "C:\Users\hazem\Desktop\New folder (4)\HM\PDF"
If strPath <> "C:\Users\hazem\Desktop\New folder (4)\HM\PDF" Then
Exit Sub
End If
strPath = strPath & "\"
'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
'create default name for savng file
strFile = Filename1 & "_" & filename3 & " " & "of" & " " & filename2 & " " & "at" & " " & strTime & ".pdf"
strPathFile = strFile
'use can enter name and
' select folder for file
answer = MsgBox("Please!! Save the PDF to path (FINISHED CRS PDF OF SELECTED AUTHORITY) ", vbQuestion + vbYesNo + vbDefaultButton2, "CRS PDF CREATOR")
If answer = vbNo Then MsgBox "Please! Try again Later"
If answer = vbNo Then Exit Sub
Application.DisplayAlerts = False
ActiveWorkbook.Close savechanges:=True
MyFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
Application.DisplayAlerts = False
If MyFile = Cancel Then Exit Sub
'export to PDF if a folder was selected
MsgBox "PDF file wil be opened in seconds "
MsgBox "please click CTRL+P to print PDF and change copies to the no. you need"
If MyFile <> "False" Then
Application.EnableEvents = False
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=MyFile, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
Application.EnableEvents = True
'confirmation message with file info
MsgBox "PDF file has been created: " _
& vbCrLf _
& MyFile
MsgBox "Your Work is done here!"
MsgBox "Thank you"
End If
End sub
i have a folder with over 100 workbooks (all with the same structure) with only one sheet in it . I need a macro to open the workbook and check a hole row(9th row) if a value exist in the cells (30 columns). if this value exist , need to check the value to the below cell (10th row). if criteria met the workbook closes , else remains open for corrections
I'm new to vba so help need
my code doesn't work
Sub scannerblaine()
Dim SPath As String 'path to check
Dim sFname As String 'the name of the workbooks for scaning (if all scaned = * )
Dim wBk As Workbook
Dim wSht As Variant 'the name of the sheets to be scaned
Dim r1, r2 As Integer 'this is the rows for scanning
Dim c1 As Integer 'columns for scanning
Dim blaine, varblaine, b1, b2 As Double
Dim res As Integer
res = MsgBox(" SCANNING OF MT FOLDER" & vbCrLf & vbCrLf _
& "CHOOSE FOLDER" & vbCrLf & vbCrLf _
& "NAME OF THE EXCEL FILES" & vbCrLf & vbCrLf _
& "IF ALL THE SAME PLACE {*} " & vbCrLf & vbCrLf _
& "", vbOKCancel + vbDefaultButton2, " INFO !!!")
If res = vbCancel Then
Exit Sub
End If
Application.EnableEvents = False
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder for scanning"
.Show
.AllowMultiSelect = False
If .SelectedItems.count = 0 Then 'if no folder is selected , abort
MsgBox "You did not select a folder"
Exit Sub
End If
SPath = .SelectedItems(1) & "\" 'assign selected folder to be the scanned folder
End With
ChDir SPath
sFname = InputBox("Enter a filename pattern")
sFname = Dir(SPath & "\" & sFname & ".xl*", vbNormal)
' INPUT BOX FOR blaine ###################################################################################################
blaine = Application.InputBox("TARGET BLAINE", Type:=1)
varblaine = Application.InputBox("BLAINE VARIATION", Type:=1)
b1 = blaine - varblaine
b2 = blaine + varblaine
Dim resl As Integer
resl = MsgBox(b1 & " to " & b2, vbOKCancel + vbDefaultButton2)
If resl = vbCancel Then
Exit Sub
End If
ChDir SPath
Filename = Dir(SPath & "\" & "*.xl*")
Do While Filename <> ""
Workbooks.Open Filename:=SPath & Filename, ReadOnly:=True
Set wBk = Workbooks.Open(Filename)
For c1 = 6 To 36 '0 '########################################################################################
r1 = 9
If Cells(r1, c1) = "I52,5N" Then
If Cells(r1 + 1, c1) < b2 And Cells(r1 + 1, c1) > b1 Then
wBk.Close
End If
End If
Next c1
Application.DisplayAlerts = False
Filename = Dir()
Loop
MsgBox _
"SCAN IN FOLDER" & vbCrLf & vbCrLf _
& SPath & vbCrLf & vbCrLf _
& " COMPLETE"
End Sub
Sub scannerblaine()
Dim SPath As String 'path to check
Dim sFname As String 'the name of the workbooks for scaning (if all scaned = * )
Dim wBk As Object
Dim wSht As Variant 'the name of the sheets to be scaned
Dim r1, r2 As Integer 'this is the rows for scanning
Dim c1, c2 As Variant 'columns for scanning
Dim blaine, varblaine, b1, b2 As Integer
Dim res As Integer
res = MsgBox(" ΘΑ ΣΑΡΩΘΕΙ ΕΝΑΣ ΦΑΚΕΛΟΣ ΤΟΥ ΑΡΧΕΙΟΥ MT" & vbCrLf & vbCrLf _
& "ΕΠΕΛΕΞΕ ΠΟΙΟΣ ΑΠΟ ΤΟ ΠΑΡΑΘΥΡΟ ΔΙΑΛΟΓΟΥ" & vbCrLf & vbCrLf _
& "ΚΑΤΟΠΙΝ ΘΑ ΣΟΥ ΖΗΤΗΘΕΙ ΤΟ ΟΝΟΜΑ ΤΩΝ EXCEL ΑΡΧΕΙΩΝ" & vbCrLf & vbCrLf _
& "ΕΠΕΙΔΗ ΕΙΝΑΙ ΤΑ ΙΔΙΑ ΑΠΛΑ ΒΑΛΕ [ * ] [αστερισκος] " & vbCrLf & vbCrLf _
& "", vbOKCancel + vbDefaultButton2, " ΕΝΗΜΕΡΩΣΗ !!!")
If res = vbCancel Then
Exit Sub
End If
Application.EnableEvents = False
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder for scanning"
.Show
.AllowMultiSelect = False
If .SelectedItems.count = 0 Then 'if no folder is selected , abort
MsgBox "You did not select a folder"
Exit Sub
End If
SPath = .SelectedItems(1) & "\" 'assign selected folder to be the scanned folder
End With
ChDir SPath
sFname = InputBox("Enter a filename pattern")
sFname = Dir(SPath & "\" & sFname & ".xl*", vbNormal)
'Να φτιαξω input box για την ποιοτητα I42,5R ή I52,5N και να συμπεριλαβω την ποιοτητα στο input box του blaine παρακατω
' INPUT BOX FOR blaine ###################################################################################################
blaine = Application.InputBox("ΔΩΣΕ ΣΤΟΧΟ BLAINE", Type:=1)
varblaine = Application.InputBox("ΔΩΣΕ ΕΥΡΟΣ ΔΙΑΚΥΚΑΝΣHΣ BLAINE", Type:=1)
b1 = blaine - varblaine
b2 = blaine + varblaine
Dim resl As Integer
resl = MsgBox("ΟΡΙΑ BLAINE ΑΠΟ " & b1 & " ΕΩΣ " & b2, vbOKCancel + vbDefaultButton2)
If resl = vbCancel Then
Exit Sub
End If
ChDir SPath
Filename = Dir(SPath & "\" & "*.xl*")
Do While Filename <> ""
Workbooks.Open Filename:=SPath & Filename, ReadOnly:=True
Set wBk = Workbooks.Open(Filename)
'CHECK FOR BLAINE VALUES IN CELLS ##########################################################################################
For c1 = 6 To 30
r1 = 9
If Cells(r1, c1) = "I52,5N" Then
If Cells(r1 + 2, c1) > b2 Or Cells(r1 + 2, c1) < b1 Then GoTo c
End If
Next c1
wBk.Close
c:
Filename = Dir()
Loop
MsgBox _
"Η ΣΑΡΩΣΗ ΣΤΟΝ ΦΑΚΕΛΟ" & vbCrLf & vbCrLf _
& SPath & vbCrLf & vbCrLf _
& "ΟΛΟΚΛΗΡΩΘΗΚΕ" & vbCrLf & vbCrLf _
& "ΤΑ ΑΡΧΕΙΑ ΜΕ ΣΦΑΛΜΑΤΑ" & vbCrLf & vbCrLf _
& "ΠΑΡΑΜΕΝΟΥΝ ΑΝΟΙΧΤΑ ΓΙΑ ΕΠΕΞΕΡΓΑΣΙΑ"
End Sub