|
▼ハクエン さん:
なんとなく、原紙シートにしておられるのは以下のことかなと。
(抽出済みの行を削除したいのですよね?)
抽出結果がなかった場合の対処も付け加えました。
Sub Sample2()
Dim myKey As String
Dim mySht As String
Dim x As Long
Dim keyV As Variant
Dim shtV As Variant
Application.ScreenUpdating = False
keyV = Split("1.チームA 2.チームB 3.チームC 4.チームD 5.チームE 6.チームF 7.チームG 8.チームH")
shtV = Split("A B C D E F G H")
With Sheets("原紙")
'シートにオートフィルター設定
.AutoFilterMode = False
.Range("A1").AutoFilter
For x = 1 To 8
myKey = keyV(x - 1)
mySht = shtV(x - 1)
.AutoFilter.Range.AutoFilter Field:=4, Criteria1:=myKey
If .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
Sheets(mySht).UsedRange.Clear
.AutoFilter.Range.Copy Sheets(mySht).Range("A1")
With Sheets(mySht).UsedRange
.RowHeight = 22.5
.Resize(.Rows.Count - 1).Offset(1).Replace What:="" & Chr(10) & "", Replacement:=" ", _
LookAt:=xlPart
End With
'抽出済み行の削除
With .AutoFilter.Range
.Resize(.Rows.Count - 1).Offset(1).EntireRow.Delete
End With
End If
Next
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
MsgBox "振り分け完了"
End Sub
|
|