Excel VBA質問箱 IV

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

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


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

14457 / 76734

←次へ　｜　前へ→


	【67773】Re:特定の値を含む行の抽出で困っています。

UO3 - 11/1/7(金) 12:20 -


	引用なし

	パスワード

▼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

4 hits

▼

【67755】特定の値を含む行の抽出で困っています。 lawry 11/1/6(木) 17:27