Excel VBA質問箱 IV

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

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


14461 / 76738 ←次へ | 前へ→

【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

2 hits

【67755】特定の値を含む行の抽出で困っています。 lawry 11/1/6(木) 17:27 質問
【67770】Re:特定の値を含む行の抽出で困っています。 Jaka 11/1/7(金) 10:54 発言
【67774】Re:特定の値を含む行の抽出で困っています。 lawry 11/1/7(金) 13:29 お礼
【67772】Re:特定の値を含む行の抽出で困っています。 UO3 11/1/7(金) 11:41 発言
【67773】Re:特定の値を含む行の抽出で困っています。 UO3 11/1/7(金) 12:20 回答
【67775】Re:特定の値を含む行の抽出で困っています。 lawry 11/1/7(金) 14:30 お礼

14461 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free