有效的方法来使用Excel检查表数据来创build和填充新表中的列表
我正在开发一个项目，该项目需要一个用户创build并填写的检查表 
并且当用户运行一个macros时，创build一个新的工作簿来推断和扩展检查表数据，如下所示
它是通过这些数字劳动代码中的每一个，然后在所有适用项目的检查表中运行，并将它们添加到列表中。
现在…我有这个工作正常，并通过基本的testing运行。 我将检查表保存为一个数组，并将其传递给新的工作簿，逐行过滤和创build新的工作簿。
我只是忍不住觉得有一个更简单的方法来做到这一点，因为我现在这样做似乎并不是最简单和最稳定的方式。
我很乐意分享我迄今为止的代码，但是想知道是否给了这个senario，你将如何处理它。
这里是我的文件的链接： 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 "AE" For Each i In Range("CS_FormType") If i Like "[RS]" Then MajMinYesNo = True ElseIf i Like "[AE]" 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 (ie 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 "###[AZ]" Or LC Like "##[AZ]" 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 这里是另外一个模块，它实际上需要数组并创build新的工作簿：
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 "[AE]" 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
如果重新构build新工作表中的数据顺序是可能的，那么您似乎只能复制可见的单元格，然后编写一个简单的循环来引入任何不明确的数据（即“劳动法典”）。