Home |
Search |
Today's Posts |
|
#1
![]()
Posted to microsoft.public.excel.programming
|
|||
|
|||
![]()
I am fairly new to VB so im looking for some advice. I am looking to
write a Macro to check to see if a worksheet has been saved to another folder. The original file is saved throughout the day and then, at the end of the day, one of the tabs is saved to another folder. This file is written over once every day. I wish to check and see if the tab has been saved to the alternate folder. It is for multiple files, but i believe that i can just repeat the process. Can anyone help me to start this, or put me on the right track? Thank you. |
#2
![]()
Posted to microsoft.public.excel.programming
|
|||
|
|||
![]()
Paste the macros below into a module and call ListFilesToWorksheet().
It will list files into a new worksheet. Hope it helps. ' ' ' '=============================================== 'created using John Walkenbach's ' "Microsoft Excel 2000 Power ' Programming with VBA" example as a ' basic starting point '=============================================== '32-bit API declarations Private Declare Function SHGetPathFromIDList _ Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _ ByVal pszPath As String) As Long Private Declare Function SHBrowseForFolder _ Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _ As Long '=============================================== Private Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type '=============================================== Public Sub ListFilesToWorksheet() On Error Resume Next Dim blnSubFolders As Boolean Dim dblLastRow As Long Dim i As Integer, r As Integer, x As Integer Dim y As Integer, iWorksheets As Integer Dim Msg As String, Directory As String, strPath As String Dim strResultsTableName As String, strFilename As String Dim strWorksheetName As String Dim strFileNameFilter As String, strDefaultMatch As String Dim strExtension As String, strFileBoxDesc As String Dim strMessage_Wait1 As String, strMessage_Wait2 As String Dim varSubFolders As Variant, varAnswer As String '/==========Variables============= strResultsTableName = "File_Listing" strDefaultMatch = "*.*" r = 1 i = 1 blnSubFolders = False strMessage_Wait1 = _ "Please wait while search is in progress..." strMessage_Wait2 = _ "Please wait while formatting is completed..." '/==========Variables============= strFileNameFilter = _ InputBox("Ex: *.* with find all files" & vbCr & _ " blank will find all Office files" & vbCr & _ " *.xls will find all Excel files" & vbCr & _ " G*.doc will find all Word files beginning with G" _ & vbCr & _ " Test.txt will find only the files named TEST.TXT" _ & vbCr, _ "Enter file name to match:", Default:=strDefaultMatch) If Len(strFileNameFilter) = 0 Then varAnswer = _ MsgBox("Continue Search?", vbExclamation + vbYesNo, _ "Cancel or Continue...") If varAnswer = vbNo Then GoTo Exit_ListFiles End If End If If Len(strFileNameFilter) = 0 Then strFileBoxDesc = "All MSOffice files" Else strFileBoxDesc = strFileNameFilter End If Msg = "Look for: " & strFileBoxDesc & vbCrLf & _ " - Select location of files to be " & _ "listed or press Cancel." Directory = GetDirectory(Msg) If Directory = "" Then Exit Sub End If If Right(Directory, 1) < Application.PathSeparator Then Directory = Directory & Application.PathSeparator End If varSubFolders = _ MsgBox("Search Sub-Folders of " & Directory & " ?", _ vbInformation + vbYesNoCancel, "Search Sub-Folders?") If varSubFolders = vbYes Then blnSubFolders = True If varSubFolders = vbNo Then blnSubFolders = False If varSubFolders = vbCancel Then Exit Sub 'check for an active workbook ' if no workbooks open, create one If ActiveWorkbook Is Nothing Then Workbooks.Add End If 'save name of current worksheet strWorksheetName = ActiveSheet.name 'Count number of worksheets in workbook iWorksheets = ActiveWorkbook.Sheets.Count 'Check for duplicate Worksheet name i = ActiveWorkbook.Sheets.Count For x = 1 To i If UCase(Worksheets(x).name) = _ UCase(strResultsTableName) Then Worksheets(x).Activate If Err.Number = 9 Then Exit For End If Application.DisplayAlerts = False 'turn warnings off ActiveWindow.SelectedSheets.Delete Application.DisplayAlerts = True 'turn warnings on Exit For End If Next 'Add new worksheet where results will be located Worksheets.Add.Move after:=Worksheets(ActiveSheet.name) 'Name the new worksheet and set up Titles ActiveWorkbook.ActiveSheet.name = strResultsTableName ActiveWorkbook.ActiveSheet.Range("A1").value = "Hyperlink" ActiveWorkbook.ActiveSheet.Range("B1").value = "Path" ActiveWorkbook.ActiveSheet.Range("C1").value = "FileName" ActiveWorkbook.ActiveSheet.Range("D1").value = "Extension" ActiveWorkbook.ActiveSheet.Range("E1").value = "Size" ActiveWorkbook.ActiveSheet.Range("F1").value = "Date/Time" Range("A1:E1").Font.Bold = True r = r + 1 On Error Resume Next Application.StatusBar = strMessage_Wait1 With Application.FileSearch .NewSearch .LookIn = Directory If strFileNameFilter = "*.*" Then _ .FileType = msoFileTypeAllFiles If Len(strFileNameFilter) = 0 Then _ .FileType = msoFileTypeOfficeFiles .Filename = strFileNameFilter .SearchSubFolders = blnSubFolders .Execute For i = 1 To .FoundFiles.Count strFilename = "" strPath = "" For y = Len(.FoundFiles(i)) To 1 Step -1 If Mid(.FoundFiles(i), y, 1) = _ Application.PathSeparator Then Exit For End If strFilename = _ Mid(.FoundFiles(i), y, 1) & strFilename Next y strPath = _ Left(.FoundFiles(i), _ Len(.FoundFiles(i)) - Len(strFilename)) strExtension = "" For y = Len(strFilename) To 1 Step -1 If Mid(strFilename, y, 1) = "." Then If Len(strFilename) - y < 0 Then strExtension = Right(strFilename, _ Len(strFilename) - y) strFilename = Left(strFilename, y - 1) Exit For End If End If Next y Cells(r, 1) = .FoundFiles(i) ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, 1), _ Address:=.FoundFiles(i) Cells(r, 2) = strPath Cells(r, 3) = strFilename Cells(r, 4) = strExtension Cells(r, 5) = FileLen(.FoundFiles(i)) Cells(r, 6) = FileDateTime(.FoundFiles(i)) r = r + 1 Next i End With 'formatting Application.StatusBar = strMessage_Wait2 ActiveWindow.Zoom = 75 Columns("E:E").Select With Selection .NumberFormat = _ "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)" End With Columns("F:F").Select With Selection .HorizontalAlignment = xlLeft End With Columns("A:F").EntireColumn.AutoFit Columns("A:A").Select If Selection.ColumnWidth 12 Then Selection.ColumnWidth = 12 End If Range("A2").Select ActiveWindow.FreezePanes = True Rows("1:1").Select Selection.Insert Shift:=xlDown dblLastRow = 65000 ActiveWorkbook.ActiveSheet.Range("A1").WrapText = False If Len(strFileNameFilter) = 0 Then strFileNameFilter = "All MSOffice products" End If If blnSubFolders Then Directory = "(including Subfolders) - " & Directory End If Application.ActiveCell.Formula = "=SUBTOTAL(3,A3:A" & _ dblLastRow & ") & " & Chr(34) & _ " files(s) found for Criteria: " & _ Directory & strFileNameFilter & Chr(34) Selection.Font.Bold = True Range("B3").Select Selection.Sort Key1:=Range("B3"), _ Order1:=xlAscending, Key2:=Range("A3") _ , Order2:=xlAscending, HEADER:=xlGuess, _ OrderCustom:=1, MatchCase:= _ False, Orientation:=xlTopToBottom Range("A3").Select Application.Dialogs(xlDialogWorkbookName).Show Exit_ListFiles: Application.StatusBar = False Exit Sub Err_ListFiles: MsgBox "Error: " & Err & " - " & Err.Description Resume Exit_ListFiles End Sub '=============================================== Private Function GetDirectory(Optional Msg) As String Dim bInfo As BROWSEINFO Dim iFileSystemDirectoriesOnly As Long Dim iDialogType As Long Dim iBrowseForComputers As Long Dim iBrowseForPrinters As Long Dim iBrowseIncludesFiles As Long Dim Path As String Dim r As Long, x As Long, Pos As Integer iFileSystemDirectoriesOnly = 0 iDialogType = 0 iBrowseForComputers = 0 iBrowseForPrinters = 0 iBrowseIncludesFiles = 0 '- - - - - - - - - - - - - - - - - ' Only return file system directories. iFileSystemDirectoriesOnly = &H1 ' Dialog style with context menu and resizability ' iDialogType = &H40 ' Only returns computers ' iBrowseForComputers = &H1000 ' Only return printers ' iBrowseForPrinters = &H2000 ' The browse dialog will display files as well as folders ' iBrowseIncludesFiles = &H4000 ' Root folder = Desktop bInfo.pidlRoot = 0& ' Title in the dialog If IsMissing(Msg) Then bInfo.lpszTitle = "Select a folder." Else bInfo.lpszTitle = Msg End If ' Type of directory to return ' bInfo.ulFlags = &H1 bInfo.ulFlags = _ iFileSystemDirectoriesOnly + _ iDialogType + _ iBrowseForComputers + _ iBrowseForPrinters + _ iBrowseIncludesFiles ' Display the dialog x = SHBrowseForFolder(bInfo) ' Parse the result Path = Space$(512) r = SHGetPathFromIDList(ByVal x, ByVal Path) If r Then Pos = InStr(Path, Chr$(0)) GetDirectory = Left(Path, Pos - 1) Else GetDirectory = "" End If End Function '=============================================== 'Gary Brown 'If this post was helpful to you, please select ''YES'' at the bottom of the post. |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
![]() |
||||
Thread | Forum | |||
Files saved as csv files are actually saved as text files? | Excel Discussion (Misc queries) | |||
Searching Files | Excel Discussion (Misc queries) | |||
.xml files to be saved as .xls files as XML list | Excel Programming | |||
Searching for files that contain ??? | Excel Programming | |||
Searching For Files with Dates | Excel Programming |