Follow along with the video below to see how to install our site as a web app on your home screen.
Note: This feature may not be available in some browsers.
Option Explicit
Dim scrFso As Object 'a FileSystemObject which will be set with scripting
Dim oFolder As Object 'the folder object
Dim oContentFolders As Object 'the subfolders contained in the oFolder
Dim oFile As Object 'the file object
Dim oFiles As Object 'the files object
Dim strMonth, strYear As String 'the number of the month and year in which we are at the moment
Dim i As Integer 'a counter
Dim WbTarget As Workbook 'Where everything will go
Dim StrName As String 'the name of each file as we open it
Dim Wkbk As Workbook
Dim rFound, rTotals As Range
Dim YNOverwrite As Boolean 'user answer about whether to overwrite files
Dim strRoot As String 'Where we get the files from
Sub OpenAllFilesInFolder()
'stop the screen flickering
Application.ScreenUpdating = False
i = 0
'Given that the workbook will be open if you are running this macro, set it as the target for the collated data
Set WbTarget = ActiveWorkbook
'Set WbTarget = Workbooks.Open(Filename:="P:\Docs\Mark Griffiths\Worksheets.xlsx")
strRoot = "P:\Docs\WORKSHEETS"
'ask the user if they want to add to the current list or replace it
If MsgBox("Do you wish to overwrite the entire file? Clicking NO will update for this month only", vbYesNo, "Collate Worksheets to File") = vbYes Then
YNOverwrite = True
Else
YNOverwrite = False
End If
'If the user wishes to add to the data, record the current month and year so we can add only latest data
strMonth = CStr(Month(CDate(Now)))
strYear = CStr(Year(CDate(Now)))
'the month number should be two digit
If Len(strMonth) < 2 Then strMonth = "0" & strMonth
'search the subfolders for Excel Files
SearchContents strRoot
'turn updating back on
Application.ScreenUpdating = True
End Sub
Sub SearchContents(strRoot As String)
'starts at path strRoot and looks at its subfolders and files
'if there are files below it calls RunThrough, which opens them one by one
'once its checked for files, it calls itself to check for subfolders.
If scrFso Is Nothing Then Set scrFso = CreateObject("scripting.filesystemobject")
'start looking in the place we said to look
Set oFolder = scrFso.GetFolder(strRoot)
'tell it to be aware of sub folders
Set oContentFolders = oFolder.subfolders
For Each oFolder In oContentFolders
'tell is to be aware of any files in the sub folder
Set oFiles = oFolder.Files
'if the folder you are looking in contains folders, look in those folders themselves, but if you are not overwriting, check that it is a right folder
If YNOverwrite = False Then
If oFiles.Count > 0 And oFolder.Name = strMonth Then
RunThrough oFolder.Path
Else
GoTo nextone
End If
Else
RunThrough oFolder.Path
End If
nextone:
'call ourselves in a moebus whatsit to see if there are subfolders below
SearchContents oFolder.Path
Next
End Sub
Sub RunThrough(strPath As String)
' runs through a folder oPath, opening each file in that folder,
' calling a macro, and then closing each file in that folder
'if we are repeating this it may already be set, otherwise, set it
If scrFso Is Nothing Then Set scrFso = CreateObject("scripting.filesystemobject")
'set up the subfolders to be searched
Set oFolder = scrFso.GetFolder(strPath)
For Each oFile In oFolder.Files
StrName = oFile.Name 'the name of this file
Application.StatusBar = strPath & "\" & StrName 'the status bar is just to let us know where we are
'open the file Name only if it is an Excel document
If Right(StrName, 4) = ".xls" Or Right(StrName, 5) = ".xlsx" Then
If YNOverwrite = True Then
'If you only want to overwrite this year, then ensure the name is this year's
If Left(StrName, 4) = strYear Then
'Make sure that the file is not readonly, and run overwrite
Set Wkbk = Workbooks.Open(Filename:=strPath & "\" & StrName, ReadOnly:=False)
Overwrite Wkbk
Else
'nothing
End If
Else
'If you are updating, check if the name of the file implies that it is a recent one
If Left(StrName, 4) = strYear Then
Set Wkbk = Workbooks.Open(Filename:=strPath & "\" & StrName, ReadOnly:=False)
Update Wkbk
Else
'nothing
End If
End If
End If
Next
NextoFile:
'return control of status bar to Excel
Application.StatusBar = False
End Sub
Sub Overwrite(Wkbk As Workbook)
'Only bother doing this if there actually is the standard summary sheet
If Sheets(1).Name = "Summary" Then
'count one more than last time this was run so we keep moving down the target spreadsheet
i = i + 1
'go to the summary sheet and search for the totals row in column A
Sheets("Summary").Activate
Set rFound = Cells.Find("Totals", Cells(1, 1), xlValues, xlWhole, xlByRows, xlNext, False)
'extend the range out to get all the data and copy it
Range(rFound.Cells(1, 2), rFound.Cells(1, 49)).Copy
'Go to the target workbook and the right place
WbTarget.Activate
WbTarget.Sheets("Data").Range("A2").Cells(i, 1).Activate
'If the workbook from which we are getting data has a standard name, extract the date and the user
If Left(Wkbk.Name, 2) = 20 Then
ActiveCell.Value = Left(Wkbk.Name, 4) & "\" & Mid(Wkbk.Name, 6, 2)
ActiveCell.Cells(1, 2).Value = Mid(Wkbk.Name, 9, 3)
Else
'otherwise, just put in the name as it appears
ActiveCell.Value = Wkbk.Name
End If
'Paste the data
ActiveCell.Cells(1, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Else
'if the workbook does not contain the summary sheet, skip ahead to where we close it
GoTo end1
End If
end1:
'close without saving
Wkbk.Close (False)
End Sub
Sub Update(Wkbk As Workbook)
'Only bother doing this if there actually is the standard summary sheet
If Sheets(1).Name = "Summary" Then
'go to the summary sheet and search for the totals row in column A
Sheets("Summary").Activate
Set rFound = Cells.Find("Totals", Cells(1, 1), xlValues, xlWhole, xlByRows, xlNext, False)
'extend the range out to get all the data and copy it
Range(rFound.Cells(1, 2), rFound.Cells(1, 49)).Copy
'Go to the target workbook and the right place
WbTarget.Activate
WbTarget.Sheets("Data").Range("A65536").End(xlUp).Offset(1, 0).Activate
'If the workbook from which we are getting data has a standard name, extract the date and the user
If Left(Wkbk.Name, 2) = 20 Then
ActiveCell.Value = Left(Wkbk.Name, 4) & "\" & Mid(Wkbk.Name, 6, 2)
ActiveCell.Cells(1, 2).Value = Mid(Wkbk.Name, 9, 3)
Else
'otherwise, just put in the name as it appears
ActiveCell.Value = Wkbk.Name
End If
'Paste the data
ActiveCell.Cells(1, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Else
'if the workbook does not contain the summary sheet, skip ahead to where we close it
GoTo end2
End If
end2:
'close without saving
Wkbk.Close (False)
End Sub
I understand that i have to change my sheet into a table.
If I just make the whole thing a table, fill it in white and lose the headers so it looks normal, does it change anything inherent about the sheet?
Will it still function the same?