Copying sheets from closed files? format during or after?

Question

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

paul bica paul bica · Accepted Answer · 2017-09-29T03:33:28

Maybe these procedures will help

Option Explicit

Public Sub Test4Operations()

    Application.ScreenUpdating = False

        FreezeRow ActiveSheet, 2

        FilterWs ThisWorkbook.Worksheets("Sheet1"), 1, Array("3", "5", "7", "9")

        RemoveWorksheets ThisWorkbook, "Sheet2, Sheet3"

        CopyWsToEnd ActiveSheet

    Application.ScreenUpdating = True

End Sub

1

Public Sub FreezeRow(ByRef ws As Worksheet, Optional ByVal staticRow As Long = 2, _
                                            Optional ByVal staticCol As Long = 1)

    If Not ws Is Nothing And staticRow > 1 And staticCol > 0 Then
        Dim activeWs As Worksheet

        If ActiveSheet.Name <> ws.Name Then
            Set activeWs = ActiveSheet
            ws.Activate
        End If

        With ActiveWindow
            ws.AutoFilterMode = False
            If .FreezePanes Then .FreezePanes = False
            If .Split And Not .FreezePanes Then .Split = False

            '.SplitRow = staticRow
            '.SplitColumn = staticCol - 1
            ws.Cells(staticRow, staticCol).Activate
            .FreezePanes = True
        End With

        If Not activeWs Is Nothing Then activeWs.Activate
    End If
End Sub

2

Public Sub FilterWs(ByRef ws As Worksheet, ByVal colID As Long, ByRef fby As Variant)

    If Not ws Is Nothing And colID > 0 And Not IsEmpty(fby) Then

        If ws.AutoFilterMode Then ws.UsedRange.AutoFilter

        With ws.UsedRange.Columns(colID)
            .AutoFilter Field:=1, Criteria1:=fby, Operator:=xlFilterValues
        End With

    End If
End Sub

3

'call: RemoveWorksheets ThisWorkbook, "1, 2", or: Array("Sheet1, Sheet2"), or: 3
'    unused VarType(wsIds):
'    Case vbNull, vbSingle, vbDouble, vbCurrency, vbDate, vbDecimal, vbVariant
'    Case vbObject, vbError, vbBoolean, vbUserDefinedType, vbDataObject

Public Sub RemoveWorksheets(ByRef wb As Workbook, ByRef wsIds As Variant)

    If Not wb Is Nothing And Not IsEmpty(wsIds) Then
        Dim ws As Worksheet, arr As Variant, itm As Variant

        Select Case VarType(wsIds)
            Case vbString
                arr = Split(wsIds, ",")
                If UBound(arr) = 0 Then arr = Split(wsIds)
            Case vbByte, vbInteger, vbLong: arr = Array(wsIds)
            Case vbArray, 8204: arr = wsIds
        End Select

        Application.DisplayAlerts = False
        For Each ws In wb.Worksheets
            For Each itm In arr
                If wb.Worksheets.Count > 1 Then
                    If IsNumeric(itm) Then
                        If ws.Index = Val(itm) Then ws.Delete
                    Else
                        If ws.Name = Trim$(itm) Then ws.Delete
                    End If
                End If
            Next
        Next
        Application.DisplayAlerts = True
    End If
End Sub

4

Public Sub CopyWsToEnd(ByRef ws As Worksheet)
    If Not ws Is Nothing Then
        ws.UsedRange.Columns.AutoFit
        ws.Copy After:=Worksheets(Worksheets.Count)
        ws.Activate
        ws.AutoFilterMode = False
    End If
End Sub

Copying sheets from closed files? format during or after?

1 Answers

1

2

3

4