| |
フィルタオプションとオートフィルタを使った、私案を参考までに示します。
なお、フィルタオプションを使う関係で、見出しが必須です。
・ListシートのA3,C3,F3,F3,S3には項目見出しを入れます。
・ClientシートのA1,B1,C1にも見出しを、
それぞれListシートのA3,C3,S3と全く同一のものを記入してください。
Sub 明細シート作成3()
Dim wsList As Worksheet
Dim wsClient As Worksheet
Dim wsForm As Worksheet
Dim ws As Worksheet
Dim lastRow As Long
Dim myRange As Range
Dim myBody As Range
Dim r As Range
Dim rowsClient As Long
Dim n As Long
Dim txt As String
Dim no As String
Dim name As String
Dim k As Long
Set wsList = Worksheets("List")
Set wsClient = Worksheets("Client")
Set wsForm = Worksheets("Form")
'フィルタ範囲の指定
lastRow = wsList.Cells(wsList.Rows.Count, 1).End(xlUp).Row
Set myRange = wsList.Range(wsList.Cells(3, "A"), wsList.Cells(lastRow, "S"))
'その本体部分（つまり見出しを除いた部分）
Set myBody = Intersect(myRange, myRange.Offset(1))
'重複を除いて抽出
myRange.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=wsClient.Range("A1:C1"), Unique:=True
'転記
rowsClient = wsClient.Cells(wsClient.Rows.Count, 1).End(xlUp).Row
For n = 2 To rowsClient
txt = wsClient.Cells(n, 1).Value '受注No
no = wsClient.Cells(n, 2).Value '管理No
name = wsClient.Cells(n, 3).Value '注文者氏名
'管理No 毎のシートを作成
wsForm.Copy After:=Worksheets(Worksheets.Count)
Set ws = ActiveSheet
ws.name = txt
'固定項目の転記
ws.Range("B34").Value = txt
ws.Range("B5").Value = no
ws.Range("A3").Value = name
'管理Noを指定して抽出（品目毎データの転記用）
myRange.AutoFilter Field:=3, Criteria1:=no
'その転記
k = 25
For Each r In myBody.Columns(1).SpecialCells(xlCellTypeVisible)
ws.Cells(k, 1) = r.Cells(1, 6).Value
ws.Cells(k, 8) = r.Cells(1, 8).Value
k = k + 1
Next
Next
myRange.AutoFilter
End Sub
|
|
γ
- 18/7/16(月) 7:33 -
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
