Question

我将继续扩展从大型机中提取数据的排序和组织功能。这个问题涉及从question's focus扩展功能。数据是字母数字，与此previously asked question中的数据类似。

我试图允许用户在我的数据集的标准表中使用1个项目的列表，以及多个项目。我的代码如下：

'This subroutine is intended to take filtered data and use it to fill forms.
'These forms use a very basic text template worksheet, which is copied over for each worksheet.
'In general, these forms will number from 1 to 100, for discussion purposes.
'The idea is that each row of data in the DataSheet will be used to fill each worksheet tab.

Sub Shifter()


Dim RngOne As Range, RngCell As Range
Dim RngTwo As Range
Dim RngThree As Range, RngCell2 As Range 'RngCell2 is not currently in use
Dim RngRow As Range

Dim LastCell As Long

Dim arrList() As String, LongCount As Long

'Define range data within the Criteria Sheet
With Sheets("Criteria")
    LastCell = .Range("A" & Sheets("Criteria").Rows.Count).End(xlUp).Row
    If LastCell <= 1 Then
        MsgBox ("Please do not leave the Criteria sheet blank. Note that all criteria belong under Column A.")
        Exit Sub
    ElseIf LastCell = 2 Then
        Set RngOne = .Range("A2")
    Else
        Set RngOne = .Range("A2:A" & LastCell)
    End If
End With

'Push values into the array
LongCount = 0
For Each RngCell In RngOne
    ReDim Preserve arrList(LongCount)
    arrList(LongCount) = RngCell.Text
    LongCount = LongCount + 1
Next


'Filter the values to the desired criteria stored in the array.
With Sheets("Sheet1")

LastSheetCellCheck = .Range("A" & Sheets("Sheet1").Rows.Count).End(xlUp).Row
If LastCell <= 1 Then
    MsgBox ("Please do not leave the Criteria sheet blank. Note that all criteria belong under Column A.")
    Exit Sub
End If

Call ShiftToText
'For when this process is repeated.
If .FilterMode Then .ShowAllData

.Range("A:A").AutoFilter Field:=1, Criteria1:=arrList, Operator:=xlFilterValues

End With

'Add a Sheet to contain the filtered criteria
Sheets.Add After:=Sheets(1)
Sheets(2).Name = "DataSheet"

'With the original dataset, snag all existing data based on the range in Sheet Criteria.
'This avoids potential empty junk data and potential blanks pulled from the mainframe.
With Sheets("Sheet1")

LastCell = .Range("A" & Sheets("Criteria").Rows.Count).End(xlUp).Row
Set RngTwo = .Range("A2:AA" & LastCell)

End With

'Push data into DataSheet worksheet, so data is sequential
Sheets(1).Select
RngTwo.Copy
Sheets("DataSheet").Select
ActiveSheet.Paste

'Define the ranges used within the sheet
With Sheets("DataSheet")

If LastCell = 2 Then

    Set RngThree = .Range("A2")

Else

    LastCell = .Range("A" & Sheets("Criteria").Rows.Count).End(xlUp).Row
    Set RngThree = .Range("A2:A" & LastCell)

End If

End With

'For each row in the range, (1) generate a new datasheet, and copy the form from the template to the new sheet.
'(2) Rename the datasheet to be the value in Row 1, Column 1 ("A1").
'(3) Copy over information to the form based on column location in the Datasheet.
'This method, even if made functional, is both procedural and limited in scope. Recursion with text matching will be the end goal for this form.
For Each RngRow In RngThree.Rows

Sheets.Add After:=Sheets(1)

'Grab the text form from the Template and push it into the new sheet.
Sheets("TemplateSheet").Select
Cells.Select
Selection.Copy
Sheets(2).Select
ActiveSheet.Paste

Sheets(2).Name = Sheets("DataSheet").Cells(RngRow.Row, 1).Value

Sheets(2).Range("B3").Value = Sheets("DataSheet").Cells(RngRow.Row, 1).Value

Sheets(2).Range("B5").Value = Sheets("DataSheet").Cells(RngRow.Row, 2).Value

Sheets(2).Range("D3").Value = Sheets("DataSheet").Cells(RngRow.Row, 3).Value

Sheets(2).Range("F3").Value = Sheets("DataSheet").Cells(RngRow.Row, 4).Value

Sheets(2).Range("B10").Value = Sheets("DataSheet").Cells(RngRow.Row, 5).Value

Sheets(2).Range("B7").Value = Sheets("DataSheet").Cells(RngRow.Row, 6).Value

Sheets(2).Range("D10").Value = Sheets("DataSheet").Cells(RngRow.Row, 7).Value

Sheets(2).Range("F10").Value = Sheets("DataSheet").Cells(RngRow.Row, 8).Value

Sheets(2).Range("B13").Value = Sheets("DataSheet").Cells(RngRow.Row, 9).Value

Sheets(2).Range("D13").Value = Sheets("DataSheet").Cells(RngRow.Row, 10).Value

Sheets(2).Range("F13").Value = Sheets("DataSheet").Cells(RngRow.Row, 11).Value

Sheets(2).Range("B16").Value = Sheets("DataSheet").Cells(RngRow.Row, 12).Value

Sheets(2).Range("D16").Value = Sheets("DataSheet").Cells(RngRow.Row, 13).Value

Sheets(2).Range("F16").Value = Sheets("DataSheet").Cells(RngRow.Row, 14).Value

Sheets(2).Range("B19").Value = Sheets("DataSheet").Cells(RngRow.Row, 15).Value

Sheets(2).Range("D19").Value = Sheets("DataSheet").Cells(RngRow.Row, 16).Value

Sheets(2).Range("F19").Value = Sheets("DataSheet").Cells(RngRow.Row, 17).Value

Sheets(2).Range("B21").Value = Sheets("DataSheet").Cells(RngRow.Row, 18).Value

Sheets(2).Range("D21").Value = Sheets("DataSheet").Cells(RngRow.Row, 19).Value

Sheets(2).Range("B23").Value = Sheets("DataSheet").Cells(RngRow.Row, 20).Value

Sheets(2).Range("D23").Value = Sheets("DataSheet").Cells(RngRow.Row, 21).Value

 'Concatenate values from certain fields into one field
Sheets(2).Range("A26").Value = Sheets("DataSheet").Cells(RngRow.Row, 23).Value & Cells(RngRow.Row, 24).Value & Cells(RngRow.Row, 24).Value & Cells(RngRow.Row, 25).Value & Cells(RngRow.Row, 26).Value & Cells(RngRow.Row, 27).Value


Next RngRow


End Sub

目前，代码的执行导致第106行的{1004'运行时错误：Sheets(2).Name = Sheets("DataSheet").Cells(RngRow.Row, 1).Value。

我尽可能避免使用On Error Resume代码块，因为我认为它们是最后的手段，但我有点死路一条，并且可以使用面向对象的辅助/建议/一般的VBA解决方案。

修改

有关其他说明，请添加简单代码

MsgBox (Sheets(2).Name)

之后

Sheets(2).Name = Sheets("DataSheet").Cells(RngRow.Row, 1).Value

在Rng.Rows = 1时返回“A2”的测试值“100-AAA”。此外，通过调用删除脚本developed with this question，在代码执行开始时删除测试表。代码在Rng.Rows = 2时失败。

Answer 1

我想我找到了你的答案......

在您的代码中：

With Sheets("Sheet1")

LastCell = .Range("A" & Sheets("Criteria").Rows.Count).End(xlUp).Row
Set RngTwo = .Range("A2:AA" & LastCell)

End With

'Push data into DataSheet worksheet, so data is sequential
Sheets(1).Select
RngTwo.Copy
Sheets("DataSheet").Select
ActiveSheet.Paste

您Set RngTwo = .Range("A2:AA" & LastCell)，表示粘贴到DataSheet时未添加标题。然后在下面，这个块

If LastCell = 2 Then

    Set RngThree = .Range("A2")

无效，因为您只复制了1行数据，因此A2为空。您可能没有注意到，因为没有错误，但这也意味着当条件大于1时总是忽略DataSheet列表中的第一个元素。

我认为有两种解决方案：更改LastCell检查以设置从第1行开始的范围：

If LastCell = 2 Then
    Set RngThree = .Range("A1") 'CHANGE THIS LINE
Else
    LastCell = .Range("A" & Sheets("Criteria").Rows.Count).End(xlUp).Row
    Set RngThree = .Range("A1:A" & LastCell) 'CHANGE THIS LINE
End If

OR 设置您的副本范围以包含第一个标题行：

With Sheets("Sheet1")

LastCell = .Range("A" & Sheets("Criteria").Rows.Count).End(xlUp).Row
Set RngTwo = .Range("A1:AA" & LastCell) 'CHANGE THIS LINE

End With

'Push data into DataSheet worksheet, so data is sequential
Sheets(1).Select
RngTwo.Copy
Sheets("DataSheet").Select
ActiveSheet.Paste

为了记录，我用一个和多个标准测试了上述两个选项。一切似乎都适合我。

我希望这会有所帮助......

Range.Rows = 2 - VBA上的循环中断

1 个答案: