时间戳

首页 > 解决方案 > 循环遍历索引和匹配模板的员工 ID 列表？

vba - 循环遍历索引和匹配模板的员工 ID 列表？

问题描述

我有一个工作簿，其中包含员工 ID（控制表）、数据及其 ID 和各种薪酬信息（数据表）以及显示模板及其薪酬报表（绩效表）的工作表。

优点表有一个表单模板，它根据索引/匹配公式填充一堆框（所有引用都来自该表上单元格 P1 中的员工 ID）。

我的同事正在使用这个容易出错的极其复杂的 VBA 脚本，我想知道是否有更简单的方法可以做到这一点：

  1. 转到控制表，找到第一个员工 ID（有一个标题行）
  2. 在优点表的单元格 P1 中填充该 ID
  3. 将新填写的数据导出为 .pdf
  4. 循环到控制表中的下一个员工 ID，直到所有都被制作成 .pdf 在绩效表中。

原始代码：

Sub Statement_Autoprint()
'
' Macro1 Macro

Dim StartTime As Date
StartTime = Now()

Dim MCST As Workbook
Set MCST = ActiveWorkbook
Dim User As String
User = Environ$("Username")
Dim SavePath As String
Dim MgrPath As String
SavePath = "C:\Users\" & User & "\Desktop\Manual Comp Statements\"

If Dir(SavePath, vbDirectory) = vbNullString Then
    MkDir SavePath
End If

Dim LoopRow As Integer
Dim Printed As Integer
LoopRow = 2
Printed = 0

Dim Emplid As String
Dim EmpName As String
Dim MgrName As String
Dim Statement As String
Dim Range As Range
Dim rowstocheck As Range
'With MCST.Sheets(Statement)

'End With

On Error GoTo ErrorHandler:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

Do While Trim(MCST.Sheets("Control Sheet").Range("B" & LoopRow)) <> ""

    If Trim(MCST.Sheets("Control Sheet").Range("A" & LoopRow)) <> "" Then
        Statement = MCST.Sheets("Control Sheet").Range("A" & LoopRow)
        Emplid = Format(MCST.Sheets("Control Sheet").Range("B" & LoopRow), "000000000")

        MCST.Sheets(Statement).Activate
        MCST.Sheets(Statement).Calculate
        MCST.Sheets(Statement).Range("P1") = Emplid
            Set rowstocheck = MCST.Sheets(Statement).Range("N2:N70")     
                For Each Cell In rowstocheck
                If Cell.Value = "HIDE" Then
                        Cell.EntireRow.Hidden = True
                ElseIf Cell.Value <> "HIDE" Then Cell.EntireRow.Hidden = False
                End If
                Next Cell                                              
        If Not Application.CalculationState = xlDone Then
            DoEvents
        End If

        EmpName = MCST.Sheets(Statement).Range("C5")
        MgrName = MCST.Sheets(Statement).Range("K5")

        MgrPath = "C:\Users\" & User & "\Desktop\Manual Comp Statements\" & MgrName & "\"
        If Dir(MgrPath, vbDirectory) = vbNullString Then
            MkDir MgrPath
        End If

        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=MgrPath & "2018 Mid-Year Comp Statement - " & EmpName & ".pdf", _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
        Printed = Printed + 1
    End If
    LoopRow = LoopRow + 1
Loop

Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True

Sheets("Control Sheet").Activate

MsgBox "Execution Complete;" & vbCrLf & _
        Round((Now() - StartTime) * 86400, 0) & " Second Run Time." & vbCrLf & _
        (LoopRow - 2) & " Considered" & vbCrLf & _
        Printed & " Statements Printed"

Exit Sub

ErrorHandler:
    Resume Next
End Sub

Sub Reactivate_Functions()
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

我只是觉得它不需要这么复杂，这对于我想要实现的目标来说是否过于复杂？我宁愿有一些更简单的东西，这样我就可以理解在代码中断的情况下要修复什么。

标签： vba

解决方案

I started this but won't have time to finish today. I tried to condense this so you could follow and hopefully see the pain points yourself.

I would get rid of the For Each MyCell loop and just filter on your criteria HIDE. Looping & Hiding can be time consuming so a filter would be much faster.

Option Explicit

Sub Statement_Autoprint()

Dim StartTime As Date: StartTime = Now()

Dim MCST As Workbook: Set MCST = ActiveWorkbook
Dim User As String: User = Environ$("Username")
Dim SavePath As String: SavePath = "C:\Users\" & User & "\Desktop\Manual Comp Statements\"
Dim CS As Worksheet: Set CS = MCST.Sheets("Control Sheet")

Dim MgrPath As String, MyCell As Range, Printed As Integer, i As Integer, SM As Worksheet
Printed = 0

If Dir(SavePath, vbDirectory) <> "" Then
    MkDir SavePath
End If

Call Disable

For i = 2 To CS.Range("B" & CS.Rows.Count).End(xlUp).Row
    If CS.Range("A" & i) <> "" & CS.Range("B" & i) <> "" Then
        Set SM = MCST.Sheets(CS.Range("A" & i))
        SM.Calculate
        SM.Range("P1") = Format(CS.Range("B" & i), "000000000")

            For Each MyCell In SM.Range("N2:N70")
                If MyCell = "HIDE" Then
                    MyCell.EntireRow.Hidden = True
                ElseIf MyCell <> "HIDE" Then
                    MyCell.EntireRow.Hidden = False
                End If
            Next MyCell

        If Not Application.CalculationState = xlDone Then
            DoEvents
        End If

        MgrPath = "C:\Users\" & User & "\Desktop\Manual Comp Statements\" & SM.Range("K5") & "\"

        If Dir(MgrPath, vbDirectory) <> "" Then
            MkDir MgrPath
        End If

        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=MgrPath & "2018 Mid-Year Comp Statement - " & SM.Range("C5") & ".pdf", _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
            OpenAfterPublish:=False

        Printed = Printed + 1
    End If
Next i

CS.Activate

Call Re_Enable

MsgBox "Execution Complete;" & vbCrLf & _
        Round((Now() - StartTime) * 86400, 0) & " Second Run Time." & vbCrLf & _
        (i - 2) & " Considered" & vbCrLf & _
        Printed & " Statements Printed"

End Sub

Sub Disable()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
End Sub

Sub Re_Enable()
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

推荐阅读