VBA - 按当前日期

Question

我最初向合并3个工作簿发布了一个问题，但只是批评发布了这个问题。

尽管如此，我已找到问题的解决方案，并在此处将 ALONG 发布在原始查询中以供将来参考。

方案：

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

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

3） csv 文件命名为：

• 的 Date_Terminations
• 的 Date_Terminations_Non_HR
• Date_Terminations_Tool

我已经有了将这些文件复制到新文件夹中的脚本，并在没有日期的情况下重命名它们：

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

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

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

简而言之，我需要代码来识别当天每个工作簿中的列，并将这些相邻行复制到 Terminations_Template 工作簿。

Answer 1

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

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

谢谢 尝试以有效的方式有效地使用循环

Answer 2

<强>解决方案：

这是我从头到尾的过程：

1） 3 csv exports 被提取到

中

{目录路径} - 使用以下文件名：

<强> {日期} _Daily_Terminations

<强> {日期} _Daily_Terminations_NON_HR

<强> {日期} _Daily_Terminations_TOOL

2）我运行一个脚本：

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

• 将 3 xlsx文件重命名为

  每日终止

  每日终止非人力资源

  每日终止工具

• 打开包含 4张的终止模板xlsm 文件：

  综合

  每日终止

  每日终止非人力资源

  每日终止工具

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

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

代码：

    Sub RenameOriginalFilesSheets()

    Const TestMode = True
    Dim WB As Workbook

    Application.ScreenUpdating = False
    rootpath = "{directory path}"

    aFile = Dir(rootpath & "*.xlsx")
    Do
        Set WB = Application.Workbooks.Open(rootpath & aFile, False, AddToMRU:=False)

        WB.Sheets(1).Name = Left$(WB.Name, InStrRev(WB.Name, ".") - 1)
        WB.Close True

        aFile = Dir()
        DoEvents
    Loop Until aFile = ""

    Application.ScreenUpdating = True

End Sub

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

代码：

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

• 将3张合并为一张 - **合并

Sub Consolidate（）

    '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

• 过滤 合并表格按日期显示不包括前一天 - 如果今天是第3天，则会显示所有记录除了第二个
之外的记录

代码的

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