id:japan-nan
ポイントあり500ptベストアンサーあり
コンピュータ

1359827577 Excelの関数またはVBAで、結合セル参照と複数条件により値を抽出したい

参照ファイルをご確認いただきまして、
左上部にIDを入力すると、
左リストから複数条件のもと右リストに値貼り付ける

条件として、
IDは、複数ある場合がある、その場合、対象が０であったら合算される
対象は、０は対象として９は対象外で、対象のものだけ右リストに表示させます

関数またはソースで回答いただきたくよろしくお願いします。

回答の条件
  • 1人5回まで
  • 登録：
  • 終了：2013/02/03 13:13:32
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。
id:japan-nan

質問者から

japan-nan2013/02/03 04:05:40

関数式でしたらありがたいです。

規約違反として通知

ベストアンサー

id:oil999 No.1

回答回数1728ベストアンサー獲得回数320

ポイント400pt

以下のマクロをお試しください。

最初に変数を設定しておく必要があります。
左上部のIDがあるセルはidに、
左リストのタイトル行がある列番号をcol0に、行番号をrow0に
集計先のタイトル行がある列番号をcol1に、行番号をrow1に
それぞれ設定してください。

Option Explicit

Sub main()
    Dim sheet As String
    Dim col0 As Long, row0 As Long, col1 As Long, row1 As Long
    Dim id As Integer, i As Integer, j As Integer, k As Integer
    Dim items(10) As Integer

    sheet = "Sheet1"    'シート名
    Worksheets(sheet).Select
    
    id = Cells(2, 2)  'ID番号のあるセル（この例では2行目のB列）
    col0 = 1    '読み取り元の表タイトルのある列番号（A列なら1）
    row0 = 4    '読み取り元の表タイトルのある行番号（4行目なら4）
    col1 = 7    'コピー先の表タイトルのある列番号（G列なら7）
    row1 = 4    'コピー先の表タイトルのある行番号（4行目なら4）

    'タイトル行のコピー
    For i = 0 To 4
        Cells(row1, col1 + i).Value = Cells(row0, col0 + i).Value
    Next i
    
    '集計
    row0 = row0 + 1
    row1 = row1 + 1
    While (Cells(row0, col0).Value <> "" And IsNumeric(Cells(row0, col0).Value))
        i = Cells(row0, col0).Value
        If (i = id) Then
            If (Cells(row0, col0 + 1).Value = 0) Then
                For j = 0 To 2
                    For k = 0 To 2
                        items(j * 3 + k) = items(j * 3 + k) + Cells(row0 + j, col0 + 2 + k).Value
                    Next k
                Next j
            End If
        End If
        row0 = row0 + 3
    Wend

   '結果の書き込み
    Cells(row1, col1).Value = id
    Cells(row1, col1 + 1).Value = 0
    For j = 0 To 8
        Cells(row1 + j \ 3, col1 + 2 + j Mod 3).Value = items(j)
    Next j
End Sub

その他の回答（1件）

id:oil999 No.1

回答回数1728ベストアンサー獲得回数320ここでベストアンサー

ポイント400pt

以下のマクロをお試しください。

最初に変数を設定しておく必要があります。
左上部のIDがあるセルはidに、
左リストのタイトル行がある列番号をcol0に、行番号をrow0に
集計先のタイトル行がある列番号をcol1に、行番号をrow1に
それぞれ設定してください。

Option Explicit

Sub main()
    Dim sheet As String
    Dim col0 As Long, row0 As Long, col1 As Long, row1 As Long
    Dim id As Integer, i As Integer, j As Integer, k As Integer
    Dim items(10) As Integer

    sheet = "Sheet1"    'シート名
    Worksheets(sheet).Select
    
    id = Cells(2, 2)  'ID番号のあるセル（この例では2行目のB列）
    col0 = 1    '読み取り元の表タイトルのある列番号（A列なら1）
    row0 = 4    '読み取り元の表タイトルのある行番号（4行目なら4）
    col1 = 7    'コピー先の表タイトルのある列番号（G列なら7）
    row1 = 4    'コピー先の表タイトルのある行番号（4行目なら4）

    'タイトル行のコピー
    For i = 0 To 4
        Cells(row1, col1 + i).Value = Cells(row0, col0 + i).Value
    Next i
    
    '集計
    row0 = row0 + 1
    row1 = row1 + 1
    While (Cells(row0, col0).Value <> "" And IsNumeric(Cells(row0, col0).Value))
        i = Cells(row0, col0).Value
        If (i = id) Then
            If (Cells(row0, col0 + 1).Value = 0) Then
                For j = 0 To 2
                    For k = 0 To 2
                        items(j * 3 + k) = items(j * 3 + k) + Cells(row0 + j, col0 + 2 + k).Value
                    Next k
                Next j
            End If
        End If
        row0 = row0 + 3
    Wend

   '結果の書き込み
    Cells(row1, col1).Value = id
    Cells(row1, col1 + 1).Value = 0
    For j = 0 To 8
        Cells(row1 + j \ 3, col1 + 2 + j Mod 3).Value = items(j)
    Next j
End Sub
id:taknt No.2

回答回数13539ベストアンサー獲得回数1198

ポイント100pt 
Sub idset()

    Dim a As Long
    
    ID入力位置行 = 2
    ID入力位置列 = 2
    
    'データがある行から指定(見出しは のぞく)
    左ID開始行 = 5
    左ID開始列 = 1
    
    右ID開始行 = 5
    右ID開始列 = 7
    
    b = Cells(ID入力位置行, ID入力位置列)
    
    f = 0
    For a = 左ID開始行 To Rows.Count Step 3
        If Cells(a, 左ID開始列) = "" Then Exit For
        
        If Cells(a, 左ID開始列) = b And Cells(a, 左ID開始列 + 1) = 0 Then
            If f = 0 Then
                Cells(右ID開始行, 右ID開始列) = Cells(a, 左ID開始列)
                Cells(右ID開始行, 右ID開始列 + 1) = Cells(a, 左ID開始列 + 1)
                
                Cells(右ID開始行, 右ID開始列 + 2) = Cells(a, 左ID開始列 + 2)
                Cells(右ID開始行, 右ID開始列 + 3) = Cells(a, 左ID開始列 + 3)
                Cells(右ID開始行, 右ID開始列 + 4) = Cells(a, 左ID開始列 + 4)
                
                Cells(右ID開始行 + 1, 右ID開始列 + 2) = Cells(a + 1, 左ID開始列 + 2)
                Cells(右ID開始行 + 1, 右ID開始列 + 3) = Cells(a + 1, 左ID開始列 + 3)
                Cells(右ID開始行 + 1, 右ID開始列 + 4) = Cells(a + 1, 左ID開始列 + 4)
                
                Cells(右ID開始行 + 2, 右ID開始列 + 2) = Cells(a + 2, 左ID開始列 + 2)
                Cells(右ID開始行 + 2, 右ID開始列 + 3) = Cells(a + 2, 左ID開始列 + 3)
                Cells(右ID開始行 + 2, 右ID開始列 + 4) = Cells(a + 2, 左ID開始列 + 4)
                f = 1
            Else
                Cells(右ID開始行, 右ID開始列 + 2) = Cells(a, 左ID開始列 + 2) + Cells(右ID開始行, 右ID開始列 + 2)
                Cells(右ID開始行, 右ID開始列 + 3) = Cells(a, 左ID開始列 + 3) + Cells(右ID開始行, 右ID開始列 + 3)
                Cells(右ID開始行, 右ID開始列 + 4) = Cells(a, 左ID開始列 + 4) + Cells(右ID開始行, 右ID開始列 + 4)
                
                Cells(右ID開始行 + 1, 右ID開始列 + 2) = Cells(a + 1, 左ID開始列 + 2) + Cells(右ID開始行 + 1, 右ID開始列 + 2)
                Cells(右ID開始行 + 1, 右ID開始列 + 3) = Cells(a + 1, 左ID開始列 + 3) + Cells(右ID開始行 + 1, 右ID開始列 + 3)
                Cells(右ID開始行 + 1, 右ID開始列 + 4) = Cells(a + 1, 左ID開始列 + 4) + Cells(右ID開始行 + 1, 右ID開始列 + 4)
                
                Cells(右ID開始行 + 2, 右ID開始列 + 2) = Cells(a + 2, 左ID開始列 + 2) + Cells(右ID開始行 + 2, 右ID開始列 + 2)
                Cells(右ID開始行 + 2, 右ID開始列 + 3) = Cells(a + 2, 左ID開始列 + 3) + Cells(右ID開始行 + 2, 右ID開始列 + 3)
                Cells(右ID開始行 + 2, 右ID開始列 + 4) = Cells(a + 2, 左ID開始列 + 4) + Cells(右ID開始行 + 2, 右ID開始列 + 4)
            End If
        End If
    Next a

End Sub

セルの位置は 最初にセットしている箇所で変更してください。

とりあえず IDを入力する箇所を B2とし、それを基準に それぞれ割り当ててます。

マクロは この表のあるシートに記述してください。

コメント（0件)

コメントはまだありません

この質問への反応（ブックマークコメント）

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません
ユーザー登録をして使いはじめる!無料
すでに登録されている方はこちらからログイン
この質問に含まれるキーワード
知りたいことを検索してみよう
▲ページトップへ