Automation assistance - VBA newb

N

nachelle

New Member
Joined
Mar 11, 2020
Messages
5
Office Version
  1. 2016
Platform
  1. Windows
Good afternoon!

I have a workbook that is rather complex and has been worked on by several people at this point. Currently, there are two buttons: "Fetch all File Details" and "Calculate & Sort". The "Calculate & Sort" is a more simple macro assigned to "Macro2", but "Fetch all File Details" is... a lot. I have been trying for a while now to find a way to automate pressing these buttons every 10 minutes (pressing "Fetch all File Details" first and then "Calculate & Sort"). I cannot seem to get it to work. I am going to try to copy the VBA code below for the Active sheet and Workbook. I understand it is a lot and probably messy. Is there any way you lovely people can help getting these automated?

Thanks,
Nachelle

Sheet1:


VBA Code: 
Private Sub btnBrowse_Click()
    On Error GoTo err
    
    Application.FileDialog(msoFileDialogFolderPicker).Show
    
    Sheet1.txtPath.Text = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems.Item(1)
    
err:
    Exit Sub
End Sub

Private Sub btnFetchFiles_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal x As Single, ByVal y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)

End Sub



Private Sub btnFetchFiles_Click()
    
    iRow = 14
    fPath = Sheet1.txtPath.Text
    If fPath <> "" Then
        
        Set FSO = New Scripting.FileSystemObject
        If FSO.FolderExists(fPath) <> False Then
            Set SourceFolder = FSO.GetFolder(fPath)
            
            
            If Sheet1.chkBoxIsSubFolder.Value = True Then
                IsSubFolder = True
            Else
                IsSubFolder = False
                If SourceFolder.Files.Count = 0 Then
                    MsgBox "No files exists in this Folder" & vbNewLine & vbNewLine & "Check your folder path and Try Again !!"
                    Exit Sub
                End If
            End If
            
            Call ClearResult
                        
            If CheckBox1.Value = True Then
            
                Call ListFilesInFolder(SourceFolder, IsSubFolder)
                Call ResultSorting(xlAscending, "D14", "C14", "E14")
            Else
            
                Call ListFilesInFolderXtn(SourceFolder, IsSubFolder)
                Call ResultSorting(xlAscending, "D14", "C14", "E14")
            End If
            
            lblFCount.Caption = iRow - 14
            
        Else
            MsgBox "Selected Path Does Not Exist !!" & vbNewLine & vbNewLine & "Select Correct One and Try Again !!"
        End If
    Else
        MsgBox "Folder Path Can not be Empty !!"
    End If

End Sub

Private Sub CheckBox1_Click()

If CheckBox1.Value = True Then

For i = 0 To ListBoxFileTypes.ListCount - 1
ListBoxFileTypes.Selected(i) = False
Next
End If
End Sub

Private Sub ComboBox1_Change()
    
    Select Case (ComboBox2.Value)
        
    Case "Ascending"
        
        If ComboBox1.Value = "Last Modified" Then
            
            Call ResultSorting(xlAscending, "D14", "C14", "E14")
            
        End If
        If ComboBox1.Value = "File Name" Then
            
            Call ResultSorting(xlAscending, "C14", "D14", "H14")
            
        End If
        If ComboBox1.Value = "Timestamp" Then
            
            Call ResultSorting(xlAscending, "L14", "D14", "C14")
            
        End If
        If ComboBox1.Value = "Initials" Then
            
            Call ResultSorting(xlAscending, "J14", "H14", "C14")
            
        End If
        
        
    Case "Descending"
        
        If ComboBox1.Value = "Last Modified" Then
            
            Call ResultSorting(xlDescending, "D14", "C14", "E14")
            
        End If
        If ComboBox1.Value = "File Name" Then
            
            Call ResultSorting(xlDescending, "C14", "D14", "H14")
            
        End If
        If ComboBox1.Value = "Timestamp" Then
            
            Call ResultSorting(xlDescending, "L14", "D14", "C14")
            
        End If
        If ComboBox1.Value = "Initials" Then
            
            Call ResultSorting(xlDescending, "J14", "H14", "C14")
            
        End If
        
    Case Default
        Exit Sub
        
    End Select
    
End Sub





Private Sub ComboBox2_Change()
    
    Select Case (ComboBox2.Value)
        
    Case "Ascending"
        
        If ComboBox1.Value = "Last Modified" Then
            
            Call ResultSorting(xlAscending, "D14", "C14", "E14")
            
        End If
        If ComboBox1.Value = "File Name" Then
            
            Call ResultSorting(xlAscending, "C14", "D14", "H14")
            
        End If
        If ComboBox1.Value = "Timestamp" Then
            
            Call ResultSorting(xlAscending, "L14", "D14", "C14")
            
        End If
        If ComboBox1.Value = "Initials" Then
            
            Call ResultSorting(xlAscending, "J14", "H14", "C14")
            
        End If
        
        
    Case "Descending"
        
        If ComboBox1.Value = "Last Modified" Then
            
            Call ResultSorting(xlDescending, "D14", "C14", "E14")
            
        End If
        If ComboBox1.Value = "File Name" Then
            
            Call ResultSorting(xlDescending, "C14", "D14", "H14")
            
        End If
        If ComboBox1.Value = "Timestamp" Then
            
            Call ResultSorting(xlDescending, "L14", "D14", "C14")
            
        End If
        If ComboBox1.Value = "Initials" Then
            
            Call ResultSorting(xlDescending, "J14", "H14", "C14")
            
        End If
        
    Case Default
        Exit Sub
        
    End Select
    
    
    
End Sub

Private Sub ComboBox2_DropButtonClick()
    If ComboBox2.ListCount = 0 Then
        ComboBox2.AddItem ("Ascending")
        ComboBox2.AddItem ("Descending")
        ComboBox2.Value = "Ascending"
    End If
End Sub

Private Sub ComboBox1_DropButtonClick()
    If ComboBox1.ListCount = 0 Then
        ComboBox1.AddItem ("Last Modified")
        ComboBox1.AddItem ("File Name")
        ComboBox1.AddItem ("Timestamp")
        ComboBox1.AddItem ("Initials")
        ComboBox1.Value = "File Name"
    End If
End Sub






Private Sub CommandButton1_Click()
UserForm1.Show
End Sub

Private Sub CommandButton2_Click()
Export_to_excel
End Sub

Private Sub Label3_Click()

End Sub

Private Sub Image1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal x As Single, ByVal y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)

End Sub

Private Sub Label1_Click()

End Sub

Private Sub Label2_Click()

End Sub

Private Sub Label4_Click()

End Sub

Private Sub ListBoxFileTypes_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, ByVal x As Single, ByVal y As Single, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)

End Sub

Private Sub ListBoxFileTypes_Change()
Dim i As Integer
If CheckBox1.Value = True Then
For i = 0 To ListBoxFileTypes.ListCount - 1

If ListBoxFileTypes.Selected(i) = True Then
CheckBox1.Value = False
Exit For
End If

Next
End If
End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub




ThisWorkbook:

VBA Code: 
Option Explicit

Private Sub Workbook_Open()
 
    With ActiveWorkbook.Sheets("Table")
 
       .Protect Password:="0000", userInterfaceOnly:=True
 
       .EnableOutlining = True
 
    End With
 


Dim ArrFileType(25) As Variant


ArrFileType(0) = "Microsoft Office Excel 97-2003 Worksheet(.xls)"
ArrFileType(1) = "Microsoft Office Excel Worksheet(.xlsx)"
ArrFileType(2) = "Microsoft Office Excel Macro-Enabled Worksheet(.xlsm)"
ArrFileType(3) = "Word Document 97-2003 (.doc)"
ArrFileType(4) = "Word Document 2007-2010 (.docx)"
ArrFileType(5) = "Text Document (.txt)"
ArrFileType(6) = "Adobe Acrobat Document(.pdf)"
ArrFileType(7) = "Compressed (zipped) Folder(.Zip)"
ArrFileType(8) = "WinRAR archive(.rar)"
ArrFileType(9) = "Configuration settings (.ini)"
ArrFileType(10) = "GIF File(.gif)"
ArrFileType(11) = "PNG File(.png)"
ArrFileType(12) = "JPG File(.jpg)"
ArrFileType(13) = "MP3 Format Sound (.mp3)"
ArrFileType(14) = "M3U File (.m3u)"
ArrFileType(15) = "Rich Text Format(.rtf)"
ArrFileType(16) = "MP4 Video(.mp4)"
ArrFileType(17) = "Video Clip(.avi)"
ArrFileType(18) = "Windows Media Player(.mkv)"
ArrFileType(19) = "SRT File(.srt)"
ArrFileType(20) = "PHP File(.php)"
ArrFileType(21) = "Firefox HTML Document(.htm, .html)"
ArrFileType(22) = "Cascading Style Sheet Document(.css)"
ArrFileType(23) = "JScript Script File(.js)"
ArrFileType(24) = "XML Document(.xml)"
ArrFileType(25) = "Windows Batch File(.bat)"


Sheet1.ListBoxFileTypes.List = ArrFileType
Sheet1.CheckBox1.Value = True


End Sub

Private Sub Workbook_RowsetComplete(ByVal Description As String, ByVal Sheet As String, ByVal Success As Boolean)

End Sub

Private Sub Workbook_Sync(ByVal SyncEventType As Office.MsoSyncEventType)

End Sub


Module (modFManager):



VBA Code: 
Public fPath As String
Public IsSubFolder As Boolean
Public iRow As Long
Public FSO As Scripting.FileSystemObject
Public SourceFolder As Scripting.folder, SubFolder As Scripting.folder
Public FileItem As Scripting.File
Public IsFileTypeExists As Boolean




Public Sub ListFilesInFolder(SourceFolder As Scripting.folder, IncludeSubfolders As Boolean)
    
    
    On Error GoTo 0
    For Each FileItem In SourceFolder.Files
    
    
    Application.ScreenUpdating = False
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationManual
    Application.StatusBar = False
    
            
' display file properties
    Cells(iRow, 2).Formula = iRow - 13
    Cells(iRow, 3).Formula = FileItem.Name
    Cells(iRow, 4).Formula = FileItem.DateLastModified
    Cells(iRow, 5).Select

        Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
        FileItem.Path, TextToDisplay:="Click Here to Open"
        
'Cells(iRow, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)"
        
        iRow = iRow + 1 ' next row number
        Next FileItem
        
        If IncludeSubfolders Then
            For Each SubFolder In SourceFolder.SubFolders
                ListFilesInFolder SubFolder, True
                Next SubFolder
            End If
            
            Set FileItem = Nothing
            Set SourceFolder = Nothing
            Set FSO = Nothing
            
            
        End Sub
        
        
        
        
        Public Sub ListFilesInFolderXtn(SourceFolder As Scripting.folder, IncludeSubfolders As Boolean)
            
            
            
            On Error GoTo 0
            Dim FileArray As Variant
            
            FileArray = Get_File_Type_Array
            
            For Each FileItem In SourceFolder.Files
                
                Call ReturnFileType(FileItem.Type, FileArray)
                
                If IsFileTypeExists = True Then
                    
                    Cells(iRow, 2).Formula = iRow - 13
                    Cells(iRow, 3).Formula = FileItem.Name
                    Cells(iRow, 4).Formula = FileItem.DateLastModified
                    Cells(iRow, 5).Select
                        
                        Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
                    FileItem.Path, TextToDisplay:="Click Here to Open"
                    
'Cells(iRow, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)"
                    
                    iRow = iRow + 1 ' next row number
                    
                End If
                Next FileItem
                
                If IncludeSubfolders Then
                    For Each SubFolder In SourceFolder.SubFolders
                        ListFilesInFolderXtn SubFolder, True
                        Next SubFolder
                    End If
                    
                    Set FileItem = Nothing
                    Set SourceFolder = Nothing
                    Set FSO = Nothing
                    
                               
                    
                End Sub
                
                
                
                Sub ResultSorting(xlSortOrder As String, sKey1 As String, sKey2 As String, sKey3 As String)
                    Range("C13").Select
                    Range(Selection, Selection.End(xlDown)).Select
                    Range(Selection, Selection.End(xlToRight)).Select
                    
                    Selection.Sort Key1:=Range(sKey1), Order1:=xlSortOrder, Key2:=Range(sKey2 _
                    ), Order2:=xlAscending, Key3:=Range(sKey3), Order3:=xlSortOrder, Header _
                    :=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom _
                    , DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
                    xlSortNormal
                    
                    Range("B14").Select
                End Sub
                
                
                Sub ClearResult()
                    If Range("B14") <> "" Then
                        
                        Range("B14").Select
                        Range(Selection, Selection.End(xlDown)).Select
                        Range(Selection, Selection.End(xlToRight)).Select
                        Range(Selection.Address).SpecialCells(xlCellTypeConstants).ClearContents
                    End If
                End Sub
                
                
                Public Function Get_File_Type_Array() As Variant
                                    
                    Dim i, j, TotalSelected As Integer
                    Dim arrList() As String
                    TotalSelected = 0
                    For i = 0 To Sheet1.ListBoxFileTypes.ListCount - 1
                        If Sheet1.ListBoxFileTypes.Selected(i) = True Then
                            TotalSelected = TotalSelected + 1
                        End If
                    Next
                    
                    ReDim arrList(0 To TotalSelected - 1) As String
                    j = 0
                    i = 0
                    For i = 0 To Sheet1.ListBoxFileTypes.ListCount - 1
                        
                        If Sheet1.ListBoxFileTypes.Selected(i) = True Then
                            arrList(j) = Left(Sheet1.ListBoxFileTypes.List(i), InStr(1, Sheet1.ListBoxFileTypes.List(i), "(") - 1)
                            j = j + 1
                        End If
                        
                    Next
                    
                    Get_File_Type_Array = arrList
                    
                                                           
                End Function
                
                
                Public Function ReturnFileType(fileType As String, FileArray As Variant) As Boolean
                    
                    Dim i As Integer
                   
                    IsFileTypeExists = False
                    
                    For i = 1 To UBound(FileArray) + 1
                        
                        If FileArray(i - 1) = fileType Then
                            
                            IsFileTypeExists = True
                            Exit For
                            
                        Else
                            IsFileTypeExists = False
                        End If
                        
                    Next
                    
                Application.ScreenUpdating = True
                Application.EnableEvents = False
                Application.DisplayAlerts = False
                Application.Calculate
                Application.StatusBar = True
               
                    
                End Function
                
                
                Sub textfile(iSeperator As String)
                    
                    Dim iRow, iCol
                    Dim iLine, f
                    
                    
                    
                    
                    ThisWorkbook.Activate
                    Range("B13").Select
                    TotalRowNumber = Range(Selection, Selection.End(xlDown)).Count - 12
                    
                    If iSeperator <> "vbTab" Then
                        
                        Open ThisWorkbook.Path & "\File1.txt" For Output As #1
                        Print #1, ""
                        Close #1
                        
                        Open ThisWorkbook.Path & "\File1.txt" For Append As #1
                        For iRow = 13 To TotalRowNumber
                            
                            iLine = ""
                            
                            For iCol = 2 To 7
                                
                                iLine = iLine & iSeperator & Cells(iRow, iCol).Value
                            Next
                            Print #1, iLine
                        Next
                        Close #1
                        
                        
                    Else
                        
                        Open ThisWorkbook.Path & "\File1.txt" For Output As #1
                        Print #1, ""
                        Close #1
                        
                        Open ThisWorkbook.Path & "\File1.txt" For Append As #1
                        For iRow = 13 To TotalRowNumber
                            
                            iLine = ""
                            
                            For iCol = 2 To 7
                                
                                iLine = iLine & vbTab & Cells(iRow, iCol).Value
                            Next
                            Print #1, iLine
                        Next
                        Close #1
                        
                    End If
                    
                    
                    
                    f = Shell("C:\WINDOWS\notepad.exe " & ThisWorkbook.Path & "\File1.txt", vbMaximizedFocus)
                    
'MsgBox "Your File is saved" & ThisWorkbook.Path & "\File1.txt"
                    
                End Sub
                
                
                
                
                
                Sub Export_to_excel()
                    On Error GoTo err
                    
                    
                    
                    Dim xlApp As New Excel.Application
                    Dim xlWB As New Workbook
                    
                    Set xlWB = xlApp.Workbooks.Add
'xlWB.Add
                    xlApp.Visible = False
                    
                    
                    ThisWorkbook.Activate
                    Range("B13").Select
                    Range(Selection, Selection.End(xlDown)).Select
                    Range(Selection, Selection.End(xlToRight)).Select
                    
                    Selection.Copy
                    
                    xlApp.Visible = True
                    xlWB.Activate
                    xlWB.Sheets("Sheet1").Select
                    xlWB.Sheets("Sheet1").Range("B2").PasteSpecial Paste:=xlPasteValues
                    xlWB.Sheets("Sheet1").Cells.Select
                    xlWB.Sheets("Sheet1").Cells.EntireColumn.AutoFit
                    xlWB.Sheets("Sheet1").Range("B2").Select
                    Exit Sub
err:
                    MsgBox ("Error Occured while exporting. Try again")
                    
                End Sub



Module 1:

VBA Code: 
Sub Macro2()

    Range("C14").Select
    Calculate
    Range("C14:O14").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Worksheets("File Manager").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("File Manager").Sort.SortFields.Add2 Key:=Range( _
        "O14:O9999"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("File Manager").Sort.SortFields.Add2 Key:=Range( _
        "L14:L9999"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("File Manager").Sort
        .SetRange Range("C14:O9999")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A14").Select
    Calculate


End Sub
 

Attachments

  • Sheet1.PNG
    Sheet1.PNG
    38 KB · Views: 26

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Sort by date Sort by votes
I suggest you investigate the use of the Timer function

docs.microsoft.com

Timer function (Visual Basic for Applications)

Office VBA reference topic
docs.microsoft.com

You would put some code similar to the example in the Activate event of the sheet and it would just run the background and do its thing every 10 minutes. I ran a quick test on an empty spreadsheet, just clicked around as normal and at the end of the time the finish message come up. Wouldn't have known the macro was running otherwise.
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
2-Way Cell Referencing
Replies
1
Views
135
jkpieterse
jkpieterse
K
  • Question Question
I was try to load data To List Box And Transfer data to Sheet2.... (Not work this userform)
Replies
4
Views
191
krunal123
K
K
  • Question Question
create fixtures but 2 vs 2
Replies
7
Views
155
kerm007
K
K
  • Solved
VBA in User Form. Xlookup formula for Dependent Combo Box.
Replies
8
Views
289
Kscoof
K
D
  • Question Question
VBA Code to Apply an AVERAGE of a Range on Cells as New Records are added Via a User Form
Replies
2
Views
72
Denny57
D

Forum statistics

Threads
1,223,896
Messages
6,175,265
Members
452,627
Latest member
KitkatToby

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top