[[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

コメント返信：

[ 一覧(最新更新順) ]

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

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