Excel 从关闭的文件复制工作表？格式化期间还是之后？

所以我有一段代码用于日常任务。我需要将每天更新的一堆文件合并到一个工作簿文件中。我正在打开文件夹并将其中的所有工作表复制到主工作簿中

到目前为止，它的效果非常好，我现在只需要做一些格式化、过滤和清理。制作一个新的sub或在主sub内作为副本的一部分进行此操作更好吗

我需要：

冻结新图纸的第一行 向每个复制的工作表添加筛选器 删除不必要的工作表\ 固定导入图纸的位置。 对于1：我只希望所有导入的图纸都冻结在第一行

对于2：有几种不同的表格格式和结构，我需要按特定类型过滤它们。例如：需要按State=TX筛选，但列的顺序不同，名称也不同。一些col被命名为STATE，一些col被命名为Area，一些col被命名为Region

对于3：实际上，我只需要从每个文件中导入几个工作表，但当前代码会捕获所有工作表。如何在初始子文件中仅选择某些图纸名称，或者如何根据图纸名称（如keeper1*、keeper2*、keeper3）删除/保留图纸*

对于4：由于某些原因，所有导入的图纸都从sheetlocation=2开始放置。理想情况下，我希望这些文件在工作表列表的末尾打开，但不明白为什么要这样做

=========

**定义字符串和弹出式用户选择。为用户弹出一个目录选择框

Function FileNameFromPath(strFullPath As String) As String
FileNameFromPath = Right(strFullPath, Len(strFullPath) - 
InStrRev(strFullPath, "\"))
End Function

**定义字符串和弹出式用户选择

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

*主文件打开/复制脚本

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

---

也许这些程序会有所帮助

1. 3. 4.

---

也许这些程序会有所帮助

1. 3. 4.

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

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

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

'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

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