Question

我正在开发一个项目，该项目采用用户创建并填写的检查表 enter image description here

并且，当用户运行宏时，创建一个新的工作簿来推断和扩展检查表数据，如下所示

enter image description here

它的作用是遍历每个号码的劳动力代码，并在所有适用项目的检查表中运行，并将它们加到列表中。

现在......我的工作正常，并通过基本测试。我将检查表保存为数组并将其传递给新工作簿，逐行过滤和创建新工作簿。

我不禁想到有一种更简单的方法可以做到这一点，因为我现在这样做的方式似乎并不是最简单和最稳定的方式。

我愿意分享我到目前为止所拥有的代码，但是想知道你是否得到了这个，你将如何接近它。

以下是我文件的链接：https://www.dropbox.com/s/2gobdx1rcabquew/Checksheet_Template_R3.0%20-%20StkOvrflw.xls

主模块，用于检查错误并更正格式：

Option Explicit
    Public FamilyName As String
    Public ModelName As String
    Public TaskArray() As Variant
    Public TaskArrayRowCount As Integer
    Public TaskArrayColCount As Integer

Sub CreateTemplate()
    Application.EnableEvents = False
    Application.ScreenUpdating = False
'Main SubModule. Runs Formatting and Template Generation
    Dim thisWB As Workbook
    Dim TaskArray() As Variant
    Dim i As Range
    Dim MajMinYesNo As Boolean
    Dim OPOYesNo As Boolean

    If MsgBox("Are you ready to generate the Template?", vbYesNo, "Ready?") = vbNo Then
        Application.EnableEvents = True
        Application.ScreenUpdating = True
        End
    End If

    MajMinYesNo = False
    OPOYesNo = False
    Set thisWB = ActiveWorkbook
    FamilyName = thisWB.Names("Family_Name").RefersToRange
    ModelName = thisWB.Names("Model_No").RefersToRange

    Call CreateArray(thisWB)
    'Scans Form_Type Column for "R", "S", or "A-E"
    For Each i In Range("CS_FormType")
        If i Like "[RS]" Then
            MajMinYesNo = True
        ElseIf i Like "[A-E]" Then
            OPOYesNo = True
        End If
    Next

    'Generates Templates As Needed
    If MajMinYesNo Then
        If MsgBox("Generate Major/Minor Template?", vbYesNo) = vbYes Then
            Call MajorMinor_Generate.GenerateMajorMinor(thisWB)
        End If
    End If
    If OPOYesNo Then
        If MsgBox("Generate OPO Template?", vbYesNo) = vbYes Then
        Call OPO_Generate.GenerateOPO(thisWB)
        End If
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    MsgBox ("DONE!")
End Sub
Sub CreateArray(thisWB As Workbook)
'Checks formatting and creates array TaskArray() with all the checksheet data

    With thisWB.Sheets(1)
    'Confirms equal number of rows in columns "CS_TaskNo", "CS_FormType", and "CS_Task"
        If (Not Range("CS_TaskNo").Rows.count = Range("CS_FormType").Rows.count) _
            Or (Not Range("CS_TaskNo").Rows.count = Range("CS_Task").Rows.count) Then
            MsgBox ("Task_No, Form_Type, and Task_Desc row count does not match. Please fix and try again")
            Application.EnableEvents = True
            Application.ScreenUpdating = True
            End
        End If
        Call FormatCheck

        Application.Union(Range("CS_Heading"), Range("CS_TaskNo"), Range("CS_FormType"), Range("CS_Task"), Range("CS_LaborCodes"), Range("CS_Checks")).Name = "TaskArray"
        TaskArrayRowCount = Range("TaskArray").Rows.count
        TaskArrayColCount = Range("TaskArray").Columns.count
        ReDim TaskArray(TaskArrayRowCount, TaskArrayColCount)
        TaskArray = Range("TaskArray").Value
    End With
End Sub
Sub FormatCheck()
'Checks for valid labor codes and Form Types
    If (Not CheckFormType()) Or (Not CheckLC()) Then
        MsgBox ("Errors found, please check red-highlighted cells")
        Application.EnableEvents = True
        Application.ScreenUpdating = True
        End
    End If
End Sub
Function CheckFormType()
'Returns False if there's a bad Form_Type entry in range "CS_FormType", True if all OK
    Dim i As Range
    Dim ReturnVal As Boolean

    ReturnVal = True
    For Each i In Range("CS_FormType")
        Trim (UCase(i.Value))
        If Not (i Like "[ABCDEFRS]") Then
            Highlight (Cells(i.Row, i.Column))
            ReturnVal = False
        End If
    Next
    CheckFormType = ReturnVal
End Function
Function CheckLC()
'Returns False if there's a bad error code, True if all OK _
Formats labor code ranges to add spaces as needed and checks _
labor codes for proper format (###X or ##X). Skips any labor _
codes starting with "28X"

    Dim LaborCode As String
    Dim LaborCodeLength As Integer
    Dim i As Range
    Dim j As Integer
    Dim LCCell As Range
    Dim LCArray() As String
    Dim ReturnVal As Boolean

    ReturnVal = True

    For Each i In Range("CS_LaborCodes")
        Trim (UCase(i.Value))
        LaborCode = i.Value
        If Not Left(LaborCode, 3) Like "28?" Then
            LaborCodeLength = Len(LaborCode)
            'If string LaborCode is > 4, safe to assume it is a range of labor codes 123A-123F
            Select Case LaborCodeLength
            Case Is > 4
                'Formats Labor Code Range String by adding spaces if necessary (i.e. 123A-123F to 123A - 123F)
                For j = 2 To LaborCodeLength Step 1
                    If (IsNumeric(Mid(LaborCode, j, 1))) And Not IsNumeric(Mid(LaborCode, j + 1, 1)) And Not (Mid(LaborCode, j + 2, 1) = " ") Then
                        LaborCode = Left(LaborCode, j + 1) & " " & Mid(LaborCode, j + 2)
                    ElseIf IsNumeric(Mid(LaborCode, j, 1)) And Not (Mid(LaborCode, j - 1, 1) = " ") And Not IsNumeric(Mid(LaborCode, j - 1, 1)) Then
                        LaborCode = Left(LaborCode, j - 1) & " " & Mid(LaborCode, j)
                    End If
                Next
                i = LaborCode
                LCArray = Split(LaborCode, " ")
                'confirms the labor codes are valid
                If (Not IsLaborCode(LCArray(0))) Or (Not IsLaborCode(LCArray(2))) Or (Not IsLaborCodeRange(LCArray(0), LCArray(2))) Then
                    Highlight (Cells(i.Row, i.Column))
                    ReturnVal = False
                End If
            Case 0 To 4
                If Not (IsLaborCode(LaborCode)) Then
                    Highlight (Cells(i.Row, i.Column))
                    ReturnVal = False
                End If
            Case Else
                Highlight (Cells(i.Row, i.Column))
                ReturnVal = False
            End Select
        End If
    Next
    CheckLC = ReturnVal
End Function
Function IsLaborCode(LC As String) As Boolean
'returns True if Labor Code is valid, False if invalid _
Labor Code is valid if it is 2 or 3 numbers followed by a letter _
labor code format : ###X or ##X
    If LC Like "###[A-Z]" Or LC Like "##[A-Z]" Then
        IsLaborCode = True
    Else
        IsLaborCode = False
    End If
End Function
Function IsLaborCodeRange(LCOne As String, LCTwo As String) As Boolean
'returns True if the LC range is valid, False if invalid. _
checks the numerical values to make sure they match and _
makes sure the letters are ascending
    If (StrComp(Left(LCOne, Len(LCOne) - 1), Left(LCTwo, Len(LCTwo) - 1)) = 0) And LCOne < LCTwo Then
        IsLaborCodeRange = True
    Else
        IsLaborCodeRange = False
    End If
End Function

这是实际接受数组并创建新工作簿的另一个模块：

Sub GenerateMajorMinor(thisWB As Workbook)
    Dim newWB As Workbook
    Dim MajMinArray() As Variant

    Set newWB = Workbooks.Add
    With newWB
        Call FormatWorkbook
        Call CreateMajMinArray(newWB, MajMinArray)
        Call PopulateItemMaster(MajMinArray)
        Call PopulateLaborLink(MajMinArray)
        Call SaveFile(newWB, thisWB)
    End With
End Sub
Sub SaveFile(newWB As Workbook, thisWB As Workbook)
    'saves new workbook into the same file path as the checksheet
    Dim i As Integer
    Dim FileSavePath As String
    Dim FamNameSave As String

    FamNameSave = Replace(FamilyName, "/", "_")

    i = 1
    FileSavePath = thisWB.Path + "/Template (Minor and Major)_" + FamNameSave + ".xls"

a:    If Dir(FileSavePath) <> "" Then
        FileSavePath = thisWB.Path + "/Template (Minor and Major)_" + FamNameSave + "(" + CStr(i) + ").xls"
        i = i + 1
        GoTo a:
    End If
    newWB.SaveAs FileSavePath, FileFormat:=56
End Sub
Sub FormatWorkbook()
    'Names and formats sheets
    Sheets(1).Name = "Item_Master"
    Sheets(2).Name = "Labor_Link"

    With Sheets(1)
        .Range("A1") = "Company_No"
        .Range("B1") = "Family_Name"
        .Range("C1") = "Form_Type"
        .Range("D1") = "Record_Status"
        .Range("E1") = "Task_Desc"
        .Range("F1") = "Task_No"
        .Range("G1") = "Task_Seq"
        .Range("H1") = "Is_Parametric"
    End With
    With Sheets(2)
        .Range("A1") = "Company_Name"
        .Range("B1") = "Family_Name"
        .Range("C1") = "Form_Type"
        .Range("D1") = "Labor_Code"
        .Range("E1") = "Print_Control"
        .Range("F1") = "Record_Status"
        .Range("G1") = "Task_No"
    End With
End Sub
Sub CreateMajMinArray(newWB As Workbook, MajMinArray As Variant)
    'creates array, removing any OPO/BTS labor codes
    With Sheets(3)
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Dim rng As Range

    Set rng = .Range(.Range("A1"), .Cells(TaskArrayRowCount, TaskArrayColCount))
    rng = TaskArray
    For i = 1 To .Range("A1").End(xlDown).Row Step 1
            If .Cells(i, 2) Like "[A-E]" Then
                .Rows(i).Delete
                i = i - 1
            End If
        Next
        For i = 1 To .Range("A1").End(xlToRight).Column Step 1
            If Left(.Cells(1, i), 3) Like "28E" Then
                .Columns(i).Delete
                i = i - 1
            End If
        Next
        ReDim MajMinArray(.Range("A1").End(xlDown).Row, .Range("A1").End(xlToRight).Column)
        MajMinArray = .Range(.Range("A1"), .Cells(.Range("A1").End(xlDown).Row, .Range("A1").End(xlToRight).Column)).Value
        .Cells.Clear
    End With
End Sub
Sub PopulateItemMaster(MajMinArray As Variant)
    With Sheets(1)
        'Populates "Item_Master" Sheet
        For i = 2 To UBound(MajMinArray) Step 1
            .Cells(i, 2) = FamilyName
            .Cells(i, 3) = MajMinArray(i, 2)
            .Cells(i, 4) = "1"
            .Cells(i, 5) = MajMinArray(i, 3)
            .Cells(i, 6) = MajMinArray(i, 1)
            .Cells(i, 7) = MajMinArray(i, 1)
        Next
    End With
End Sub
Sub PopulateLaborLink(MajMinArray As Variant)
    Dim i As Integer
    Dim LaborCode As String
    Dim RowCount As Long
    Dim LCArray() As String
    Dim LastLetter As String
    Dim LastFormType As String

    'Initializes RowCount and PrintControl
    RowCount = 2
    PrintControl = 10

    With Sheets(2)
        For i = 4 To UBound(MajMinArray, 2) Step 1
            LaborCode = Trim(MajMinArray(1, i))
    'If Labor Code String length is > 4, safe to assume that it is a range of labor codes
            Select Case Len(LaborCode)
            Case Is > 4
                LCArray = Split(LaborCode, " ")
        'checks to see if LCArray(0) and LCArray(2) has values
        If LCArray(0) = "" Or LCArray(2) = "" Then
                    MsgBox ("Error with Labor Code range. Please check and re-run")
                    Application.EnableEvents = True
                    Application.ScreenUpdating = True
                    End
                End If

                LastLetter = Chr(Asc(Right$(LCArray(2), 1)) + 1)
                LCArray(2) = Replace(LCArray(2), Right$(LCArray(2), 1), LastLetter)
                Do
                    Call PrintLaborLinkLines(MajMinArray, LCArray(0), RowCount, i)
                    LastLetter = Chr(Asc(Right$(LCArray(0), 1)) + 1)
                    LCArray(0) = Replace(LCArray(0), Right$(LCArray(0), 1), LastLetter)
                Loop Until LCArray(0) = LCArray(2)
                Erase LCArray()
            Case Is <= 4
                Call PrintLaborLinkLines(MajMinArray, LaborCode, RowCount, i)
            End Select
        Next
    End With
End Sub
Sub PrintLaborLinkLines(MajMinArray As Variant, LaborCode As String, RowCount As Long, i As Integer)
    Dim PrintControl As Long

    PrintControl = 10
    With Sheets(2)
        For x = 2 To UBound(MajMinArray) Step 1
            If UCase(MajMinArray(x, i)) = "Y" Then
                If LastFormType <> MajMinArray(x, 2) Then
                    PrintControl = 10
                End If
                .Cells(RowCount, 2) = FamilyName
                .Cells(RowCount, 3) = MajMinArray(x, 2)
                .Cells(RowCount, 4) = LaborCode
                .Cells(RowCount, 5) = PrintControl
                .Cells(RowCount, 6) = "1"
                .Cells(RowCount, 7) = MajMinArray(x, 1)
                RowCount = RowCount + 1
                PrintControl = PrintControl + 10
                LastFormType = MajMinArray(x, 2)
            End If
        Next
    End With
End Sub

Answer 1

如果可能重新构建新工作表上的数据顺序，似乎您只能复制可见单元格，然后编写一个简单的循环来引入任何不明确的数据（即人工代码）。

使用excel检查表数据创建和填充新工作表中列表的有效方法

1 个答案: