質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

89.13%

VBA 行数だけ繰り返す

解決済

回答 3

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 191

koko2

score 17

<やりたいこと>
・"Sheet1"に元データがあります。"Data"シートに抽出シートしたデータがあり、毎回行数が変わります。
・Dataシートの行数分、抽出を繰り返します。今回ですと3回になります。
・抽出結果を"Sheet2"に貼り付けます。
・抽出結果は1行ごとにひとかたまりで、Sheet1でフィルターをかけます。手動でやりますとおよそ10行くらい抽出されます。ですので、Sheet2は30行くらいになります。

<エラー内容>
”Data”シートの2行目のデータしか検索されず、他の3行目、4行目は検索されませんでした。
For Nextの書き方が違っているのか、それとも他も含めて問題があるのかが不明です。よろしくお願いいたします。

”Data"シート
イメージ説明

Private Sub CommandButton3_Click()  ActiveCell.FormulaR1C1 = "みかん"     Sheets("Sheet1").Select     ActiveSheet.Range("$A$1:$AB$195").AutoFilter Field:=1, Criteria1:="みかん"     Sheets("Data").Select     Range("B2").Select     ActiveCell.FormulaR1C1 = "S"     Sheets("Sheet1").Select     ActiveSheet.Range("$A$1:$AB$195").AutoFilter Field:=2, Criteria1:="S"     Sheets("Data").Select     Range("C2").Select     ActiveCell.FormulaR1C1 = "A"     Sheets("Sheet1").Select     ActiveSheet.Range("$A$1:$AB$195").AutoFilter Field:=3, Criteria1:="A"     Sheets("Data").Select     Range("D2").Select     ActiveCell.FormulaR1C1 = "120"     Sheets("Sheet1").Select     ActiveSheet.Range("$A$1:$AB$195").AutoFilter Field:=4     Sheets("Data").Select     Range("E2").Select     ActiveCell.FormulaR1C1 = "10"     Sheets("Sheet1").Select     ActiveSheet.Range("$A$1:$AB$195").AutoFilter Field:=5, Criteria1:="10"     Sheets("Data").Select     Range("F2").Select     ActiveCell.FormulaR1C1 = "1200"     Sheets("Sheet1").Select     ActiveSheet.Range("$A$1:$AB$195").AutoFilter Field:=6     Range("A2:AB185").Select     Selection.Copy     Sheets("Sheet2").Select     Range("A2").Select     ActiveSheet.Paste     Sheets("Data").Select     Range("A3").Select     Application.CutCopyMode = False     ActiveCell.FormulaR1C1 = "りんご"     Sheets("Sheet1").Select     ActiveWindow.ScrollColumn = 11     ActiveWindow.ScrollColumn = 10     ActiveWindow.ScrollColumn = 9     ActiveWindow.ScrollColumn = 8     ActiveWindow.ScrollColumn = 7     ActiveWindow.ScrollColumn = 6     ActiveWindow.ScrollColumn = 5     ActiveWindow.ScrollColumn = 4     ActiveWindow.ScrollColumn = 3     ActiveWindow.ScrollColumn = 2     ActiveWindow.ScrollColumn = 1     Rows("1:1").Select     Selection.AutoFilter     Selection.AutoFilter     ActiveSheet.Range("$A$1:$AB$195").AutoFilter Field:=1, Criteria1:="りんご"     Sheets("Data").Select     Range("B3").Select     ActiveCell.FormulaR1C1 = "M"     Sheets("Sheet1").Select     ActiveSheet.Range("$A$1:$AB$195").AutoFilter Field:=2, Criteria1:="M"     Sheets("Data").Select     Range("C3").Select     ActiveCell.FormulaR1C1 = "B"     Sheets("Sheet1").Select     ActiveSheet.Range("$A$1:$AB$195").AutoFilter Field:=3, Criteria1:="B"     Sheets("Data").Select     Range("D3").Select     ActiveCell.FormulaR1C1 = "130"     Sheets("Sheet1").Select     ActiveSheet.Range("$A$1:$AB$195").AutoFilter Field:=4, Criteria1:="130"     Sheets("Data").Select     Range("E3").Select     ActiveCell.FormulaR1C1 = "20"     Sheets("Sheet1").Select     ActiveSheet.Range("$A$1:$AB$195").AutoFilter Field:=5, Criteria1:="20"     Sheets("Data").Select     Range("F3").Select     ActiveCell.FormulaR1C1 = "2600"     Sheets("Sheet1").Select     ActiveSheet.Range("$A$1:$AB$195").AutoFilter Field:=6     Range("A3:AB6").Select     Selection.Copy     Sheets("Sheet2").Select     Range("A15").Select     ActiveSheet.Paste     Sheets("Data").Select     Range("A4").Select     Application.CutCopyMode = False     ActiveCell.FormulaR1C1 = "バナナ"     Sheets("Sheet1").Select     Rows("1:1").Select     Range("L1").Activate     Selection.AutoFilter     Selection.AutoFilter     ActiveSheet.Range("$A$1:$AB$195").AutoFilter Field:=1, Criteria1:="バナナ"     Sheets("Data").Select     Range("B4").Select     Selection.Copy     Sheets("Sheet1").Select     ActiveSheet.Range("$A$1:$AB$195").AutoFilter Field:=2, Criteria1:="L"     Sheets("Data").Select     Range("C4").Select     Application.CutCopyMode = False     ActiveCell.FormulaR1C1 = "C"     Sheets("Sheet1").Select     ActiveSheet.Range("$A$1:$AB$195").AutoFilter Field:=3, Criteria1:="C"     Sheets("Data").Select     Range("D4").Select     ActiveCell.FormulaR1C1 = "140"     Sheets("Sheet1").Select     ActiveSheet.Range("$A$1:$AB$195").AutoFilter Field:=4     Sheets("Data").Select     Range("E4").Select     ActiveCell.FormulaR1C1 = "30"     Sheets("Sheet1").Select     ActiveSheet.Range("$A$1:$AB$195").AutoFilter Field:=5     Sheets("Data").Select     Range("F4").Select     ActiveCell.FormulaR1C1 = "4200"     Sheets("Sheet1").Select     ActiveSheet.Range("$A$1:$AB$195").AutoFilter Field:=6     Range("A4:AB195").Select     Selection.Copy     Sheets("Sheet2").Select     Range("A17").Select     ActiveSheet.Paste  End Sub  

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • hatena19

    2020/05/27 09:50

    Dim Kw As の行で構文エラーになりコード自体実行できないと思いますが。
    実際のコードをコピーして貼り付けください。でないと間違いの指摘はできません。

    キャンセル

  • hatena19

    2020/05/27 10:00

    Dim Kw As の行で構文エラーになり、コード自体実行できないはずです。
    実際のコードをコピーして貼り付けてください。
    実際のものと違うものを見せられても間違いは指摘できません。

    キャンセル

  • koko2

    2020/05/27 16:42

    ご連絡ありがとうございます。確かにDim Kw Asのところが記載ミスしていました。ご指摘ありがとうございます。
    また、一から作り直してみたのですが、Dataシートに抽出した2行目のデータはフィールターして、Sheet2に貼り付けができたのですが、やはり3行目のデータは何も検索してくれませんでした。

    キャンセル

回答 3

checkベストアンサー

+1

おかしいと思える部分にコメントを入れておきました。

Private Sub CommandButton3_Click()
    Dim kk As Integer
    Dim dd As Variant
    Dim Kw(7) As Variant

    With Worksheets("Data")
      maxRow = .Range("A" & Rows.Count).End(xlUp).Row '※Rangeの前に.が必要
      Debug.Print (maxRow)

    '検索
        For kk = 1 To 6
          For dd = 2 To maxRow

            Kw(kk) = .Cells(dd, kk).Value '※Kw(kk)に繰り返し上書きしているだけの無意味な処理
            Debug.Print "Kw(" & kk & "):" & Kw(kk)
          Next
        Next
    End With


    With Worksheets("Sheet1").Range("A1")
        .AutoFilter             'AutoFilter解除
        .AutoFilter 1, Kw(1)
        .AutoFilter 2, Kw(2)
        .AutoFilter 3, Kw(3)

    End With

    '必要情報のみ"Sheet2"にコピー
    '抽出データの最終行を求める
        myRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row '※求めた最終行を使用していない
    '抽出データをコピーして貼り付け
     With Sheets("Sheet1").Range("A1")
           .CurrentRegion.Copy Sheets("Sheet2").Range("A1")
     End With  

        Worksheets("Sheet1").Range("A1").AutoFilter
        Worksheets("Sheet2").Activate
        Range("A1").Select
  End Sub

結局、無意味な部分が多すぎてコードを見ただけでは何をしたいのか把握できません。
言葉で、何をしたいのかを詳細に説明してもらえますか。


提示された情報から最大限推測して、下記のような仕様だと仮定したコード例を提示しておきます。

仕様
"Data”シートに1行毎にフィルタ条件が記述してある
このフィルタ条件で"Sheet1"シートのデータにフィルターをかけて、それを"Sheet2"に順次追加コピーしていく。

コード例

Private Sub CommandButton3_Click()
    Dim MotoRng As Range
    Set MotoRng = Worksheets("Sheet1").Range("A1")

    With Worksheets("Data")
        Dim maxRow As Long
        maxRow = .Range("A" & Rows.Count).End(xlUp).Row
        '"Data"の2行目から順にループ処理
        Dim rw As Long, cl As long
        For rw = 2 To MaxRow
            MotoRng.AutoFilter             'AutoFilter解除
            '1列目から6列目までを条件にフィルターをかける
            For cl = 1 To 6
                MotoRng.AutoFilter cl, .Cells(rw, cl).Value
            Next
            'フィルターをかけた"Sheet1"のデータを"Sheet2"に追加コピーする
            With Worksheets("Sheet2")
                Dim Sheet2MaxRow As Long
                Sheet2MaxRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
                MotoRng.CurrentRegion.Copy .Range("A" & Sheet2MaxRow)
            End With
        Next
    End With

    MotoRng.AutoFilter             'AutoFilter解除

End Sub


テキストエディタ直書きなので動作確認してませんので、おかしなところがあるかも知れません。ロジックを参考にしてください。

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/05/28 19:04

    マクロの記録を行い、コードを貼り付けました。こんな感じなのですが、伝わるといいのですが。

    キャンセル

  • 2020/05/28 20:03

    消した以前のコードはもう一度表示させてください。マクロの記録のコードと両方必要です。
    できれば、どのようにフィルターをかけたかを、言葉で説明できませんか。
    また、"Sheet1"の元データの画像(一部でいいので)もアップしてもらえますか。

    キャンセル

  • 2020/05/28 21:56

    ここまで細かくコードを書いて頂きありがとうございました。
    記載いただきましたコードを参考に進めていきたいと思います。
    アドバイスしていただき本当に感謝しています。
    コードを書いていて自己解決できないことがありますのでこれからも勉強してきます。

    キャンセル

+1

Kw(k_no) = .Cells(d_no, k_no).Value
ここでデバックとなり、色々と試してみましたがうまくいきません。

VBEの画面で上記センテンスが背景黄色で実行停止したということでは?
もしそうなら、F8(ステップイン)押すと何かしらエラーメッセージが表示されませんか?

それと、提示されたVBAコードってコンパイルは通るのですか?
念のためコピペしてコンパイルしたらエラーになりましたよ。

Private Sub CommandButton1_Click()
Dim Kw As 
    Dim k_no As Long    'A列からF列


2行目のDim Kw As
As の後ろがないです。(コンパイル前にわかりましたが、、、)

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/05/27 16:47

    回答ありがとうございました。こちらの記載不足でした。ご指摘ありがとうございました。ただ、肝心のところが未解決なので、再度作り直しが必要なようです。

    キャンセル

0

エラー箇所はわかりました、エラー内容を教えて下さい。

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/05/26 23:11

    説明が不足して申し訳ありません。追記いたしました。
    もし不足がございましたら、コメントをください。
    どうぞよろしくお願いいたします。

    キャンセル

  • 2020/05/27 00:50

    つまりエラーは出ておらず、思った通りにいっていないだけだという理解でよろしいですか?
    その上で気になるのは、まず最終行が取得できているのかという点です。

    Debug.Print (maxRow)

    この部分は、デバックウインドウに結果として出力さらるので意図した値が取得できているか確認しましょう。

    また
    Debug.Print "Kw(" & k_no & "):" & Kw(k_no)

    の部分でも同様です。

    やりたい事を実現させてくれというのではなく、プログラムのどの部分でどんな結果を得たいのにできないのかを示しましょう。

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 89.13%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる