Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

8430 / 76732

←次へ　｜　前へ→


	【73876】Re:コード整理

UO3 - 13/2/27(水) 9:23 -


	引用なし

	パスワード

▼ハクエンさん：

なんとなく、原紙シートにしておられるのは以下のことかなと。
（抽出済みの行を削除したいのですよね？）
抽出結果がなかった場合の対処も付け加えました。

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

275 hits

▼

【73868】コード整理 ハクエン 13/2/26(火) 16:23