メインフレームから取得したデータの並べ替えと整理の機能を拡張し続けています。この質問は、この質問の焦点からの機能の拡張に関するものです。データは英数字であり、この以前に尋ねられた質問で見つかったものと似ています。
データセットの基準シートにある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ソリューションにaid/adviceを使用できます。
編集
さらに明確にするために、簡単なコードを追加します
MsgBox (Sheets(2).Name)
後
Sheets(2).Name = Sheets("DataSheet").Cells(RngRow.Row, 1).Value
Rng.Rows = 1で、「A2」のテスト値「100-AAA」を返します。さらに、この質問で開発された削除スクリプトを呼び出すことにより、コード実行の開始時にテストシートが削除されます。コードはRng.Rows=2で失敗します。