エクセルのVBA・マクロについての質問です。

前回下記の質問をした者です。
https://oshiete.goo.ne.jp/qa/9235960.html

快適に使わせていただいておりますが、ひとつ機能を追加したく、相談に乗って頂ければと思っております。

現在製品名毎にデータをソートして表を作って頂いておりますが、これを更に
「製品名」ごとの「納期」を「昇順」でソートをしたい場合、何をどう追加したら良いでしょうか。
また、表ごとの行間を1行から3行に変更したいのですが、そのやり方も教えていただけると助かります。

Sub Sample1() 'この行から//
Dim i As Long, wS As Worksheet
Set wS = Worksheets("Bデータ")
wS.Cells.Clear
With Worksheets("B")
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS.Range("A1"), unique:=True
For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1").AutoFilter field:=1, Criteria1:=wS.Cells(i, "A")
.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy wS.Cells(Rows.Count, "B").End(xlUp).Offset(2)
Next i
wS.Range("A:A").Delete
wS.Rows(1 & ":" & 2).Delete
wS.Columns.AutoFit
.AutoFilterMode = False
End With
End Sub 'この行まで//


表の並びとしては
製品名 納期 発注 注文 数量 メモ 在庫

こんな感じになってます。

自分なりに色々調べてみたのですが、どうしていいのか分からずお手上げです。
ぜひお知恵をお借りしたく…どうぞ、よろしくお願いします。
何か不足がありましたら補足致しますので、回答の程、宜しくお願い致します。

質問者からの補足コメント

• 

  tom04様、回答をありがとうございました。
  希望通りの結果になりました！
  
  最後に一点お伺いしたい事が…
  表同士の行間を1行ではなく2行とか3行とかに増やしたい場合はどこをいじったら宜しいでしょうか？
  
  差支え無ければ回答をお願い致します！

    補足日時：2016/04/14 13:52

No.2 ベストアンサー 回答者： tom04 回答日時： 2016/04/14 18:07

つづけてお邪魔します。

＞行間を1行ではなく2行とか3行とかに増やしたい場合は・・・

とりあえず2行あける場合のコードを記載しておきます。

Sub Sample3() 'この行から//
Dim i As Long, wS As Worksheet
Set wS = Worksheets("Bデータ")
wS.Cells.Clear
With Worksheets("B")
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS.Range("A1"), unique:=True
For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1").AutoFilter field:=1, Criteria1:=wS.Cells(i, "A")
.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy wS.Cells(Rows.Count, "B").End(xlUp).Offset(3) '①
Next i
wS.Range("A:A").Delete
wS.Rows(1 & ":" & 3).Delete '②
wS.Columns.AutoFit
.AutoFilterMode = False
For i = 1 To wS.Cells(Rows.Count, "A").End(xlUp).Row
If wS.Cells(i, "A") = "製品名" Then
wS.Cells(i, "A").CurrentRegion.Sort key1:=wS.Cells(i, "B"), order1:=xlAscending, Header:=xlYes
End If
Next i
End With
End Sub 'この行まで//

※　3行あけたい場合は
①の行を
＞.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy wS.Cells(Rows.Count, "B").End(xlUp).Offset(4)
に
②の行を
＞wS.Rows(1 & ":" & 4).Delete
と変更してみてください。m(_ _)m

この回答へのお礼

回答ありがとうございます！

凄い！ちゃんと変わりました！
これで作業もだいぶ楽になります。

本当に助かりました。

お礼日時：2016/04/15 09:23

No.1 回答者： tom04 回答日時： 2016/04/14 11:41

こんにちは！

前回回答したものです。
元のコードはそのままで最後に並び替えをしてみてはどうでしょうか？
B列の昇順で並び替えをしています。

Sub Sample2() 'この行から//
Dim i As Long, wS As Worksheet
Set wS = Worksheets("Bデータ")
wS.Cells.Clear
With Worksheets("B")
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS.Range("A1"), unique:=True
For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1").AutoFilter field:=1, Criteria1:=wS.Cells(i, "A")
.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy wS.Cells(Rows.Count, "B").End(xlUp).Offset(2)
Next i
wS.Range("A:A").Delete
wS.Rows(1 & ":" & 2).Delete
wS.Columns.AutoFit
.AutoFilterMode = False
'▼追加//
For i = 1 To wS.Cells(Rows.Count, "A").End(xlUp).Row
If wS.Cells(i, "A") = "製品名" Then
'B列をキーに昇順に並び替え//
wS.Cells(i, "A").CurrentRegion.Sort key1:=wS.Cells(i, "B"), order1:=xlAscending, Header:=xlYes
End If
Next i
'▲ここまで//
End With
End Sub 'この行まで//

こんな感じではどうでしょう？m(_ _)m

この回答へのお礼

回答ありがとうございます！

早速試してみます！
いつも助かります(´；ω；｀)

お礼日時：2016/04/14 12:26