[[20180516164207]] 『エクセル関数についてご教示ください』(ほほ) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『エクセル関数についてご教示ください』(ほほ)

ご教示お願いいたします。

条件にあったシートの抽出方法についてですが、複雑ですので下記に詳細を記載いたします。

Sheet1のD6セルに売上の金額、D7に月の金額、D8に日額の金額の記載があります。

Sheet3に一覧表を作成しており、
C行:会社名 D行:売上の金額 E行:月の金額 F行:日額の金額 G行:総合金額
H行:適用
の一覧表があります。

このときに 
条件1:D6の金額とSheet3D列の金額が一致するもので、
条件2:D7の金額とSheet3E列の金額が一致し、
条件3:D8の金額とSheet3F列が一致する
Sheet3のC〜Hの一行をSheet1のJ5を先頭行にして横一列に抽出したいのですが、
できますでしょうか。

関数でもマクロでもどちらでも構いません。

よろしくお願いいたします。

< 使用 Excel:Excel2007、使用 OS:unknown >


Sub main()
    Dim c As Range, r As Range
    Sheets("Sheet1").Range("J5:O" & Rows.Count).Clear
    Set r = Sheets("Sheet1").Range("J5")
    For Each c In Sheets("Sheet3").Range("D:D").SpecialCells(2)
        If c.Value = Sheets("Sheet1").Range("D6").Value And c.Offset(, 1).Value = Sheets("Sheet1").Range("D7").Value And c.Offset(, 2).Value = Sheets("Sheet1").Range("D8").Value Then
            r.Resize(, 6).Value = c.Offset(, -1).Resize(, 6).Value
            Set r = r.Offset(1)
        End If
    Next c
End Sub
(mm) 2018/05/16(水) 17:16

お忙しい中対応してくださりありがとうございました。

思うような結果が出て、大変満足しております。
1点15行までを制限としたいのですが、できますでしょうか。

お忙しい中恐れ入ります。
(ほほ) 2018/05/16(水) 18:07


    Set r = r.Offset(1)

    if r.row>19 then exit sub

 End If
(mm) 2018/05/16(水) 18:13

返信ありがとうございます。

Sheet1の背景を真っ白にしております。
上記のエクセルを稼働させると、Sheet3の背景の線がSheet1のセルの一番下までいってしまうので、それをどうにか15行までに抑えたいのですが対処法はありますか。

(ほほ) 2018/05/16(水) 18:17


 >15行までに抑えたい。

こういうことかなぁ。。。。?

Sub test()

    Const cRowCount As Long = 15    '既定の行数
    Const cColCount As Long = 6     '既定の列数
    Dim rngList As Range            '一覧表
    Dim rngResult As Range          '結果出力先
    Dim rngInput As Range           '入力欄
    Dim r As Range                  '各行
    Dim ixRow As Long               '出力先行番号

    With Worksheets("Sheet3")
        Set rngList = Application.Range( _
                      .Range("C1"), .Cells(Rows.Count, "C").End(xlUp)).Resize(, cColCount)
    End With
    With Worksheets("Sheet1")
        Set rngInput = .Range("D7:D9")
        Set rngResult = .Range("J5").Resize(cRowCount, cColCount)
    End With

    rngResult.ClearContents
    For Each r In rngList.Rows
        If rngInput(1).Value = r.Cells(2).Value Then
            If rngInput(2).Value = r.Cells(3).Value Then
                If rngInput(3).Value = r.Cells(4).Value Then
                    ixRow = ixRow + 1
                    With rng.Rows(ixRow)
                        If Intersect(rngResult, .Cells) Is Nothing Then Exit For
                        .Value = r.Value
                    End With
                End If
            End If
        End If
    Next
End Sub
(まっつわん) 2018/05/17(木) 08:56

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.