|
▼lawry さん:
要件を勘違いしているところもあるかもしれませんが、先ほどコメントしたことも
あわせたコード案です。(全てをループ処理で対処。AdvancedFilterは使っていません)
Option Explicit
Sub Sample()
Dim maxRow As Long
Dim c As Range
Dim tSh As Worksheet
Dim cnt2 As Long, cnt3 As Long, cntT As Long
Dim tBody As Range
Application.ScreenUpdating = False
For Each tSh In Worksheets '転記先シートのクリア
Select Case tSh.Name
Case "Sheet2", "Sheet3"
Set tBody = tSh.UsedRange
Set tBody = Intersect(tBody, tBody.Offset(1))
If Not tBody Is Nothing Then tBody.ClearContents
End Select
Next
cnt2 = 2
cnt3 = 2
With Worksheets("Sheet1")
With .UsedRange
maxRow = .Cells(.Cells.Count).Row
End With
For Each c In .Range("M2:M" & maxRow)
Set tSh = Nothing
Select Case c.Value
Case "特定値"
Set tSh = Worksheets("Sheet3")
cntT = cnt3
cnt3 = cnt3 + 1
Case ""
If WorksheetFunction.CountA(c.EntireRow) > 0 Then
Set tSh = Worksheets("Sheet2")
cntT = cnt2
cnt2 = cnt2 + 1
End If
End Select
If Not tSh Is Nothing Then
c.EntireRow.Copy Destination:=tSh.Cells(cntT, 1)
End If
Next
End With
Set tSh = Nothing
Application.ScreenUpdating = True
End Sub
|
|