So I've got this bit of code I'm using for a daily task. I need to combine a bunch of files that gets updated everyday into a single workbook file. I am opening the folder and copying all the worksheets inside to main workbook.
This works pretty great so far, I just need to now do some formatting and filtering and cleaning up. Is it better to make a new sub() or do this inside the main sub as part of the copy?
I need to:
- freeze the top row of the new sheets
- add a filter to each copied worksheet
- delete unnecessary worksheets\
- fix the location of the imported sheets.
For #1: I just want all imported sheets to be frozen at the top row.
For #2: there's several different sheet formats (col structure) and I need to filter them all by a certain type. For example: Need to filter by State=TX, but the columns are in different orders and named differently. Some cols are named "STATE", some are named "Area" and some "Region".
For #3: there's really only a few sheets I need to import from each file but the current code grabs ALL sheets. how to select only certain sheet names in initial sub() or how to delete/keep sheets afterwards based on sheet name like "keeper1*", "keeper2*", "keeper3*"
For #4: for some reason, all the imported sheets get placed starting at sheetlocation=2. Ideally, I'd like these to open up at the end of the sheet list but can't figure out why its doing this.
=========
**defining strings and popup user selections. Pops up a directory selection box for user.
Function FileNameFromPath(strFullPath As String) As String
FileNameFromPath = Right(strFullPath, Len(strFullPath) -
InStrRev(strFullPath, "\"))
End Function
**defining strings and popup user selections
Function GetFolder(strpath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strpath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem & "\"
Set fldr = Nothing
End Function
*Main file open/copy script
Sub CombineFiles()
'Define variables
Dim fso As New Scripting.FileSystemObject
Dim i As Integer, rngData As Range
Dim errcheck As Integer
Dim strpath As String, Title As String
'Path for folder to default to
strpath = "c:\directory\folder"
'Open window to select folder
Set afolder = fso.GetFolder(GetFolder(strpath))
strpath = afolder + "\"
'This keeps the screen from updating until the end, makes the macro run faster
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'This makes the file read-only during changes
With ActiveSheet
If .ProtectContents Then .Unprotect Else .Protect "", True, True, True, True
End With
'Cycles through every file in the folder with .xls* extension
Filename = Dir(strpath & "*.xls*")
Do While Filename <> ""
Workbooks.Open Filename:=strpath & Filename, ReadOnly:=True
'Loops through each sheet in file
errcheck = 0
For Each Sheet In ActiveWorkbook.Sheets
If Sheet.Visible = xlSheetVisible Then
If ActiveSheet.AutoFilterMode = True Then
Range("A1").AutoFilter
End If
Sheet.Columns(1).Insert 'inserts new col @ A for spec#
Sheet.Cells(1, 1).Value = "SPEC#" 'adds col name
Sheet.Range("A2:A" & Sheet.Cells(Sheet.Rows.Count, "B").End(xlUp).Row).Value = Filename
'inserts filename @ A2 and fills down length of colB
If ActiveSheet.AutoFilterMode = False Then
Sheet.Range("A1").AutoFilter
End If
Sheet.Columns.AutoFit
Set rngData = Range("A1").CurrentRegion
On Error Resume Next:
Sheet.Copy After:=ThisWorkbook.Sheets(1)
End If
Next Sheet
Workbooks(Filename).Close False
Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub