Excel VBA質問箱 IV

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

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


2483 / 13646 ツリー ←次へ | 前へ→

【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 お礼[未読]

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

引用なし
パスワード
   現状 下のコードを書いて、特定の値が含まれる行を抽出して別のシートに抽出したのはいいのですが、空白行が多く詰めようと思い色々なサイト等で書かれている空白行削除のマクロをつかってみましたが。空白行がまったく削除されませんでした。 
やりたい事は特定の値を含む行の抽出して別シートに揃える事なので
このコードから空白行を仕分けられるやり方、若しくは根本的に別のやり方がありましたら教えてください。 

2003を使用しています。


自分で書いたもの、
Sub findtheword()

Dim CurPos As Range
Dim i As Integer


i = 2 '行2段目から開始

Application.ScreenUpdating = False

Do
With Worksheets("sheet1")

Set CurPos = Cells(i, 13)  '特定値を含む列にあわせる

If CurPos = "" Then '値が空白だった場合 別シートに行ごとコピペ
Range(Cells(i, 1), Cells(i, 200)).Copy Destination:=Worksheets("sheet2").Cells(i, 1)
Set CurPos = CurPos.Offset(1, 0)
ElseIf CurPos = "特定値" Then '特定値だった場合 別シートに行ごとコピペ
Range(Cells(i, 1), Cells(i, 200)).Copy Destination:=Worksheets("sheet3").Cells(i, 1)
Set CurPos = CurPos.Offset(1, 0)

Else '値が上に当てはまらない場合下セルに移行する。
Set CurPos = CurPos.Offset(1, 0)

End If
End With

i = i + 1


Loop Until i = 26000
End Sub

【67770】Re:特定の値を含む行の抽出で困っていま...
発言  Jaka  - 11/1/7(金) 10:54 -

引用なし
パスワード
   え〜と、データが下記のようだった場合、上から削除していくと、2行目を削除した場合、

1行目文字あり
2行目空白
3行目空白
4行目文字あり
5行目文字あり

2行目削除すると、行が繰り上がって下のようになります。
で、カウンターは2で、次は3行目を処理します。
んでもって、2行目に繰り上がった空白は処理されません。

1行目文字あり
2行目空白
3行目文字あり
4行目文字あり

だから、セルや行の削除は下からが基本となります。
下から削除するようにすれば、うまくいくと思います。

【67772】Re:特定の値を含む行の抽出で困っていま...
発言  UO3  - 11/1/7(金) 11:41 -

引用なし
パスワード
   ▼lawry さん:

こんにちは

まず、ご提示のコードにインデントを付けますと見やすくなります。
で、この見やすくしたコードをつらつら眺めますと、修正すべきところ、改善できるところが
見えてきます。

まず、With Worksheets("sheet1")
これ自体は、大変結構なことですが、Withでシートを修飾した後のEnd With までの
セル領域には頭に .(ピリオド)をつけて、初めて有効になります。
ところが、ご提示のコードは、たとえば Range(Cells(i, 1) 。
これではWithが全く活かされていません。たまたま、マクロを実行するときにアクティブだった
シートのセルになります。仮にSheet1以外がアクティブな状態で実行すると、とんでもないことに
なりますね。全て .Range(.Cells(i, 1) といったように記述することが必要です。

特定の文字列を含む行を別シートに抽出するというテーマですから、通常ならAdvancedFilterを
用いるのが効率もいいとは思いますが、今回の場合、特定列が空白だったらSheet2。
ただし、その行が全て空白ならコピー対象からはずすということでしょうから、
・特定文字列があるものを抽出する部分はAdvancedFilter、行全体が空白ではなく、特定列が
空白だったらSheet2という部分のみをループ処理させる手もありますね。

あ、(私が誤解していないとすれば)、Sheet2へコピーしてからSheet2の空白行を削除するより
1行全体が空白ならコピーからはずすというやり方のほうがよろしいですよ。

【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

【67774】Re:特定の値を含む行の抽出で困っていま...
お礼  lawry  - 11/1/7(金) 13:29 -

引用なし
パスワード
   ▼Jaka さん:

アドバイスありがとうございます。
下から削除するやり方を試してみます。

【67775】Re:特定の値を含む行の抽出で困っていま...
お礼  lawry  - 11/1/7(金) 14:30 -

引用なし
パスワード
   ▼UO3 さん:

経験も知識もあまり無いのでご指摘大変ありがとうございました。

要件は的を得ていましたので、書いていただいたコードを試しましたら、やりたい様になっていました。 ありがとうございました。

コードも見直しやすくて大変勉強になりました。 
重ね重ねになりますが UO3さんありがとうございました。

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