1

Question

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

到目前为止，这个工作非常好，我现在只需要做一些格式化，过滤和清理。是否更好地创建一个新的sub（）或在main sub中作为副本的一部分执行此操作？

我需要：

冻结新工作表的第一行
为每个复制的工作表添加过滤器
删除不必要的工作表\
修复导入的工作表的位置。

对于＃1：我只想让所有导入的纸张冻结在顶行。

对于＃2：有几种不同的表格格式（col结构），我需要按特定类型过滤它们。例如：需要按State = TX进行过滤，但列的顺序不同，命名也不同。一些cols被命名为＆＃34; STATE＆＃34;有些被命名为＆＃34; Area＆＃34;和一些＆＃34;地区＆＃34;。

对于＃3：我真的只需要从每个文件中导入几张纸，但当前代码会抓取所有纸张。如何在初始sub（）中仅选择某些工作表名称或如何根据工作表名称删除/保留工作表，例如＆＃34; keeper1 *＆＃34;，＆＃34; keeper2 *＆＃34;，＆＃34 ; keeper3 *＆＃34;

对于＃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

Answer 1

也许这些程序会有所帮助

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

从已关闭的文件复制表格？期间或之后的格式？

1 个答案:

1

2

3

4