VBA-按当前日期筛选后合并3个excel工作簿

我最初在合并3本工作手册上发布了一个问题，但由于发布该问题，我只收到了批评

尽管如此，我已经找到了解决问题的方法，我将它和我的原始查询一起发布在这里，以供将来参考

场景：

1） 每天有3个csv文件导出；它们都来自管理员工记录的3个工具

2） 这些3个csv文件包含终止的用户，这些用户的访问权需要在当天被撤销

3） csv文件命名为：

• 终止日期
• 终止日期\u非人力资源
• 日期\u终止\u工具

我已经获得了将这些文件复制到新文件夹并重命名它们的脚本，但没有日期：

• 终止
• 非人力资源终止
• 终端工具

4） 每个csv文件包含过去6个月内需要撤销访问权限的员工的记录；我需要做的第一件事是将当前日期排序/过滤到工作表顶部

5） 然后我需要将包含当前日期的行复制到终止模板文件中

---

简言之，我需要代码来识别当前日期每个工作簿中的列，并将这些相邻行复制到终止\u模板工作簿中。

解决方案：

这是我从头到尾的过程：

1） 3个csv导出被提取到

{目录路径}-具有以下文件名：

{Date}\u每日终止

{Date}\u每日终止\u非人力资源

{Date}\u每日终止工具

2） 我运行了一个脚本：

• 将csv文件转换为xlsx文件，并删除csv副本

• 将3个xlsx文件重命名为
  每日终止
  非人力资源每日终止
  每日终止工具

• 打开包含4张图纸的终止模板xlsm文件，该文件名为：
  巩固
  每日终止
  每日终止非人力资源
  每日终止工具

3） 我执行一个宏，该宏执行以下操作：

• 重命名每日终止中的工作表；每日终止非 人力资源；每日终止工具xlsx文件与文件本身同名

代码：

• 从每日终端复制数据；每日终止非人力资源；每日终止工具工作簿，并将其放置在终止模板工作簿中相应的工作表中

代码：

• 删除下表中不相关的列：

每日终止

每日终止非人力资源

每日终止工具

代码：

• 连接特定列以创建新名称

代码：

• 对列重新排序并在连接完成后再次删除不需要的列

代码：

• 按日期过滤合并的工作表，以显示除前一天以外的所有记录-如果今天是第三天，则它将显示除第二天记录以外的所有记录

代码

---

在这里，您希望将三张已过滤日期的工作表合并为一张，请根据您的要求使用以下代码进行更改，在这里，它将合并目标文件夹中已过滤日期的所有文件

Sub simpleXlsMerger()
Dim bookList As Workbook
 Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
 Application.ScreenUpdating = False
 Set mergeObj = CreateObject("Scripting.FileSystemObject")
 Set dirObj = mergeObj.Getfolder("\\C:\ update the target folder")
 Set filesObj = dirObj.Files
 'Here it will open each and every file in the target folder
 For Each everyObj In filesObj
 Set bookList = Workbooks.Open(everyObj)
 ' To filter date
 x = CLng(Date)
 ActiveSheet.UsedRange.AutoFilter Field:=9, Criteria1:="<" & x, Operator:=xlAnd, Criteria2:="<" & x - 1
' To copy filtered item in the sheet
ActiveSheet.Range("A:T").SpecialCells(xlCellTypeVisible).Copy
ThisWorkbook.Worksheets(1).Activate
' Paste it in the Macro sheet's non empty row
Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
Application.CutCopyMode = False
bookList.Close 
Next
End Sub

Sub-simplexlsmerge（）
将书目设置为工作簿
Dim mergeObj作为对象、dirObj作为对象、filesObj作为对象、everyObj作为对象
Application.ScreenUpdating=False
设置mergeObj=CreateObject（“Scripting.FileSystemObject”）
Set dirObj=mergeObj.Getfolder（\\C:\更新目标文件夹）
设置filesObj=dirObj.Files
'在这里，它将打开目标文件夹中的每个文件
对于FileObj中的每个everyObj
Set bookList=工作簿.打开（everyObj）
'以筛选日期
x=CLng（日期）
ActiveSheet.UsedRange.AutoFilter字段：=9，标准1:=“InStrRev（Activewoorkbok.Name，”.“”-1）应为instrev（ActiveWorkbook.Name，”.“”-1）
Sub ImportDataSheets()

    'Initialize Variables
    Dim x As Workbook, y As Workbook, xWb As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim strDir As String

    'Set workbooks to be used
    Set y = Workbooks("Terminations Template.xlsm")

    'Set workbooks to be used
    Set x = Workbooks.Open("{file path}")

    'Set sheets to be used in each workbook
    Set ws2 = y.Sheets("Daily Terminations Non HR")
    Set ws1 = x.Sheets("Daily Terminations Non HR")

    'Copy sheet and close second workbook
    ws1.Cells.Copy ws2.Cells
    x.Close False

    'Set workbooks to be used
    Set x = Workbooks.Open("{file path}")

    'Set sheets to be used in each workbook
    Set ws1 = x.Sheets("Daily Terminations TOOL")
    Set ws2 = y.Sheets("Daily Terminations TOOL")

    'Copy sheet and close second workbook
    ws1.Cells.Copy ws2.Cells
    x.Close False

    'Set workbooks to be used
    Set x = Workbooks.Open("{file path}")

    'Set sheets to be used in each workbook
    Set ws1 = x.Sheets("Daily Terminations")
    Set ws2 = y.Sheets("Daily Terminations")

    'Copy sheet and close second workbook
    ws1.Cells.Copy ws2.Cells
    x.Close False

    Application.ScreenUpdating = False

    y.Activate

    For Each y In Application.Workbooks
        If Not (y Is Application.ActiveWorkbook) Then
            y.Close
        End If

    Next

    Application.ScreenUpdating = True

End Sub

Sub DeleteIrrelevantColumns()

    'Initialize variables
    Dim currentColumn As Integer
    Dim columnHeading As String
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
    Dim wrkSht As Worksheet

    'Assign worksheets to be used
    Set ws1 = ActiveWorkbook.Sheets("Daily Terminations Non HR")
    Set ws2 = ActiveWorkbook.Sheets("Daily Terminations Tool")
    Set ws3 = ActiveWorkbook.Sheets("Daily Terminations")

    'Rename headers on all sheets if matched
    For Each wrkSht In ActiveWorkbook.Worksheets
        wrkSht.Cells(1, 1).EntireRow.Replace What:="*employeeNumber*", Replacement:="Employee Number", Lookat:=xlWhole
        wrkSht.Cells(1, 1).EntireRow.Replace What:="*ts_employee_end_date*", Replacement:="Employee End Date", Lookat:=xlWhole
        wrkSht.Cells(1, 1).EntireRow.Replace What:="*cn*", Replacement:="Employee Full Name", Lookat:=xlWhole
        wrkSht.Cells(1, 1).EntireRow.Replace What:="mail", Replacement:="Employee Email", Lookat:=xlWhole
        wrkSht.Cells(1, 1).EntireRow.Replace What:="*ts_business_unit*", Replacement:="Business Unit", Lookat:=xlWhole
        wrkSht.Cells(1, 1).EntireRow.Replace What:="*ts_supervisor_employee_number*", Replacement:="Supervisor Employee Number", Lookat:=xlWhole
        wrkSht.Cells(1, 1).EntireRow.Replace What:="ts_supervisor_mail", Replacement:="Supervisor Email", Lookat:=xlWhole
        wrkSht.Cells(1, 1).EntireRow.Replace What:="*ts_branch_user*", Replacement:="Branch User", Lookat:=xlWhole
        wrkSht.Cells(1, 1).EntireRow.Replace What:="*branch_user*", Replacement:="Branch User", Lookat:=xlWhole
        wrkSht.Cells(1, 1).EntireRow.Replace What:="*status*", Replacement:="Status", Lookat:=xlWhole
        wrkSht.Cells(1, 1).EntireRow.Replace What:="*ts_organization*", Replacement:="Organization", Lookat:=xlWhole
    Next wrkSht

    'Bring ws1 into focus
    ws1.Activate

    With ws1

    For currentColumn = ws1.UsedRange.Columns.Count To 1 Step -1

        columnHeading = ws1.UsedRange.Cells(1, currentColumn).Value

        'Check whether to keep column
        Select Case columnHeading

            Case "Employee Number", "Employee End Date", "Business Unit", "Employee Email", "ts_supervisor_firstname", "ts_supervisor_surname", "Branch User", "Employee Full Name", "Supervisor Employee Number", "Status", "Supervisor Email"

                'Do nothing

            Case Else

                    ws1.Columns(currentColumn).Delete

        End Select
    Next

    End With

    'Bring ws2 into focus
    ws2.Activate

    With ws2

    For currentColumn = ws2.UsedRange.Columns.Count To 1 Step -1

        columnHeading = ws2.UsedRange.Cells(1, currentColumn).Value

        'Check whether to keep column
        Select Case columnHeading

            Case "Employee Number", "Employee End Date", "Business Unit", "Employee Email", "ts_supervisor_firstname", "ts_supervisor_surname", "Branch User", "Employee Full Name", "Supervisor Employee Number", "Status", "Supervisor Email"

                'Do nothing

            Case Else

                    ws2.Columns(currentColumn).Delete

        End Select
    Next

    End With

    'Bring ws3 into focus
    ws3.Activate

    With ws3

    For currentColumn = ws3.UsedRange.Columns.Count To 1 Step -1

        columnHeading = ws3.UsedRange.Cells(1, currentColumn).Value

        'Check whether to keep column
        Select Case columnHeading

            Case "Employee Number", "sn", "givenName", "Employee End Date", "Business Unit", "Organization", "Employee Email", "ts_supervisor_last_name", "ts_supervisor_first_name", "Supervisor Employee Number", "Branch User", "Supervisor Email"

                'Do nothing

            Case Else

                    ws3.Columns(currentColumn).Delete

        End Select
    Next

    End With

End Sub

Sub ConcatenateColumns()

    'Initialize variables
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim lngLastRow As Long

    'Assign worksheets to be used
    Set ws1 = ActiveWorkbook.Sheets("Daily Terminations Non HR")
    Set ws2 = ActiveWorkbook.Sheets("Daily Terminations Tool")
    Set ws3 = ActiveWorkbook.Sheets("Daily Terminations")

    'Bring ws1 into focus
    ws1.Activate

    With ws1


        'Uses Column A to set the 'lngLastRow' variable
        lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row

        'Range to be used for concatenation
        .Range("$M$1").Value = "Supervisor Full Name"
        .Range("M2:M" & lngLastRow).Formula = "=E2 & "" "" & F2"

    End With

    'Bring ws2 into focus
    ws2.Activate

    With ws2

        'Uses Column A to set the 'lngLastRow' variable
        lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row

        'Range to be used for concatenation
        .Range("$M$1").Value = "Supervisor Full Name"
        .Range("M2:M" & lngLastRow).Formula = "=E2 & "" "" & F2"

    End With

    'Bring ws3 into focus
    ws3.Activate

    With ws3

        'Uses Column A to set the 'lngLastRow' variable
        lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row

        'Range to be used for concatenation
        .Range("$N$1").Value = "Employee Full Name"
        .Range("N2:N" & lngLastRow).Formula = "=C2 & "" "" & B2"

    End With

    With ws3

        'Uses Column A to set the 'lngLastRow' variable
        lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row

        'Range to be used for concatenation
        .Range("$O$1").Value = "Supervisor Full Name"
        .Range("O2:O" & lngLastRow).Formula = "=I2 & "" "" & H2"

    End With

End Sub

Sub ReorderColumns()

    'Initialize variables
    Dim arrColOrder As Variant, ndx As Integer
    Dim Found As Range, Counter As Integer
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet

    'Assign worksheets to be used
    Set ws1 = ActiveWorkbook.Sheets("Daily Terminations Non HR")
    Set ws2 = ActiveWorkbook.Sheets("Daily Terminations Tool")
    Set ws3 = ActiveWorkbook.Sheets("Daily Terminations")

    'Bring ws1 into focus
    ws1.Activate

    'Initialize array for header order
    arrColOrder = Array("Employee Number", "Employee End Date", "Employee Full Name", "Employee Email", "Business Unit", _
                        "Supervisor Employee Number", "Supervisor Full Name", "Supervisor Email", "Branch User", "Status")

    'Copy and Paste Sheet as Values
    ws1.Cells.Copy
    ws1.Cells.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

    With ws1

        'Set counter value
        Counter = 1

        Application.ScreenUpdating = False

        For ndx = LBound(arrColOrder) To UBound(arrColOrder)

            Set Found = Rows("1:1").Find(arrColOrder(ndx), LookIn:=xlValues, Lookat:=xlWhole, _
                          SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)

            If Not Found Is Nothing Then

                If Found.Column <> Counter Then

                    Found.EntireColumn.Cut
                    Columns(Counter).Insert Shift:=xlToRight
                    Application.CutCopyMode = False

                End If

                Counter = Counter + 1

            End If

        Next ndx

        'Columns to delete after columns have been arranged
        ws1.Range("K:M").EntireColumn.Delete

        Application.ScreenUpdating = True

    End With

    'Bring ws2 into focus
    ws2.Activate

    'Initialize array for header order
    arrColOrder = Array("Employee Number", "Employee End Date", "Employee Full Name", "Employee Email", "Business Unit", _
                        "Supervisor Employee Number", "Supervisor Full Name", "Supervisor Email", "Branch User", "Status")

    'Copy and Paste Sheet as Values
    ws2.Cells.Copy
    ws2.Cells.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

    With ws2

        'Set counter value
        Counter = 1

        Application.ScreenUpdating = False

        For ndx = LBound(arrColOrder) To UBound(arrColOrder)

            Set Found = Rows("1:1").Find(arrColOrder(ndx), LookIn:=xlValues, Lookat:=xlWhole, _
                          SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)

            If Not Found Is Nothing Then

                If Found.Column <> Counter Then

                    Found.EntireColumn.Cut
                    Columns(Counter).Insert Shift:=xlToRight
                    Application.CutCopyMode = False

                End If

                Counter = Counter + 1

            End If

        Next ndx

        'Columns to delete after columns have been arranged
        ws2.Range("K:M").EntireColumn.Delete

        Application.ScreenUpdating = True

    End With

    'Bring ws3 into focus
    ws3.Activate

    'Initialize array for header order
    arrColOrder = Array("Employee Number", "Employee End Date", "Employee Full Name", "Employee Email", "Business Unit", "Supervisor Employee Number", "Supervisor Full Name", "Supervisor Email", "Branch User", "Organization")

    'Copy and Paste Sheet as Values
    ws3.Cells.Copy
    ws3.Cells.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

    With ws3

        'Set counter value
        Counter = 1

        Application.ScreenUpdating = False

        For ndx = LBound(arrColOrder) To UBound(arrColOrder)

            Set Found = Rows("1:1").Find(arrColOrder(ndx), LookIn:=xlValues, Lookat:=xlWhole, _
                          SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)

            If Not Found Is Nothing Then

                If Found.Column <> Counter Then

                    Found.EntireColumn.Cut
                    Columns(Counter).Insert Shift:=xlToRight
                    Application.CutCopyMode = False

                End If

                Counter = Counter + 1

            End If

        Next ndx

        'Columns to delete after columns have been arranged
        ws3.Range("K:N").EntireColumn.Delete

        'Insert new column
        ws3.Range("J:J").EntireColumn.Insert

        Application.ScreenUpdating = True

    End With

End Sub

    'Initialize variables
    Dim ws As Worksheet, ws1 As Worksheet
    Dim LastRow As Long

    'Assign worksheets to be used
    Set ws = Worksheets("Daily Terminations Non HR")
    Set ws1 = Worksheets("Consolidated")

    'Find last row
    LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

    'Copy range up to last row
    ws.Range("A2:K" & LastRow).Copy

    'Paste in next empty row
    ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

    'Bring ws1 into focus
    ws1.Activate

    'Assign worksheets to be used
    Set ws = Worksheets("Daily Terminations TOOL")
    Set ws1 = Worksheets("Consolidated")

    'Find last row
    LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

    'Copy range up to last row
    ws.Range("A2:K" & LastRow).Copy

    'Paste in next empty row
    ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

    'Bring ws1 into focus
    ws1.Activate

    'Assign worksheets to be used
    Set ws = Worksheets("Daily Terminations")
    Set ws1 = Worksheets("Consolidated")

    'Find last row
    LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

    'Copy range up to last row
    ws.Range("A2:K" & LastRow).Copy

    'Paste in next empty row
    ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

    'Bring ws1 into focus
    ws1.Activate

    'Insert new column
    ws1.Range("B:B").EntireColumn.Insert
    Range("B1").Value = "Logon"

    'Bring cell A1 into focus
    Range("A1").Select

End Sub

Sub DateFilter()

    'Initialize variables
    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Consolidated")
    Dim c As Range
    Dim LastRow As Long
    Dim Current_Date As Date

    'Find the last row with contents
    LastRow = oWS.Cells(Rows.Count, 1).End(xlUp).Row

    With oWS

        'Loop through all celss in column B and change format to date
        For Each c In ActiveSheet.Range("C2:C" & LastRow).Cells

            Current_Date = CDate(c)
            c.Value = Current_Date

        Next c

        'Make all cells in column A "General" input
        Columns(1).NumberFormat = "General"

        ' Set the autofilter to display all dates other than yesterdays
        .Range("C:C").AutoFilter Field:=1, Criteria1:="<" & CLng(DateAdd("d", -1, Date)), Operator:=xlOr, Criteria2:=">" & CLng(DateAdd("d", -1, Date))

    End With

End Sub

Sub DeleteVisiibleRows()

    'Initialize variables
    Dim sh As Worksheet, rng As Range, LstRw As Long

    'Assign sheet to be used
    Set sh = Sheets("Consolidated")

    With sh

        'Find the last row with data in it
        LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row

        'Use only filtered cells - visible cells as filter is applied; Exclusing headers
        Set rng = .Range("A2:A" & LstRw).SpecialCells(xlCellTypeVisible)

        'Delete visible cells
        rng.EntireRow.Delete

        'Remove filter
        .AutoFilterMode = False

    End With

End Sub

Sub simpleXlsMerger()
Dim bookList As Workbook
 Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
 Application.ScreenUpdating = False
 Set mergeObj = CreateObject("Scripting.FileSystemObject")
 Set dirObj = mergeObj.Getfolder("\\C:\ update the target folder")
 Set filesObj = dirObj.Files
 'Here it will open each and every file in the target folder
 For Each everyObj In filesObj
 Set bookList = Workbooks.Open(everyObj)
 ' To filter date
 x = CLng(Date)
 ActiveSheet.UsedRange.AutoFilter Field:=9, Criteria1:="<" & x, Operator:=xlAnd, Criteria2:="<" & x - 1
' To copy filtered item in the sheet
ActiveSheet.Range("A:T").SpecialCells(xlCellTypeVisible).Copy
ThisWorkbook.Worksheets(1).Activate
' Paste it in the Macro sheet's non empty row
Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
Application.CutCopyMode = False
bookList.Close 
Next
End Sub