[[20041114104955]]　『同じ会社の直前のデータを取得するには』（どらきち）　ページの最後に飛ぶ

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

　

『同じ会社の直前のデータを取得するには』（どらきち）

いつも「エクセルの学校」で勉強させていただきありがとうございます。
下記のような表がありまして、同じ会社の直前のデータを取得するマクロを
作りたいのですがどうしたらよろしいかどなたかご指導をお願いします。
下表で B6 のセルに直前のＸ社のD列のデータ　5000　を取得するにはです。
（1行目のＸ社のデータはありません） 

 　　   A          B     　C　    D

1　　　Ｘ社 　1000　　200 　　2000

2　　　Ｙ社　　　2500　　300 　3500

3　　　Ｚ社　　　3000　　400 　3000

4　　　Ｘ社　　　2000　　500 　5000

5　　　Ｙ社　　　3500　　600 　1400

6　　　Ｘ社　　　　　　　　　　　　　　

　よろしくお願いします。
　　　　　　　　　　

6　　　Ｘ社 

 数式でも出来ますけどマクロでしょうか。
 数式の場合
	 A	 B	 C	 D
  1	Ｘ社	1,000	200	2,000
  2	Ｙ社	2,500	300	3,500
  3	Ｚ社	3,000	400	3,000
  4	Ｘ社	2,000	500	5,000
  5	Ｙ社	3,500	600	1,400
  6	Ｘ社	5,000		
 B6=IF(ISNA(MATCH(A6,A1:A5,0)),"該当なし",INDEX(A1:D5,MAX((A1:A5=A6)*ROW(A1:A5)),4))		
		として、Shift+Ctrlキー押しながらEnterキーで確定して配列数式に。		


 マクロならベタベタな方法ですが、以下のような感じでしょうか。
Sub Test()
For Each c In Range("A1:A5")
    If c.Value = Range("A6") Then
        MyRow = c.Row
        If MyRow < c.Row Then
            MyRow = c.Row
        Else
            MyRow = MyRow
        End If
    End If
Next c
If IsEmpty(MyRow) Then
    MsgBox ("該当する社名がありません。")
Else
    Range("B6").Value = Cells(MyRow, 4).Value
End If
End Sub


 ※ついでに、チェンジイベントの場合です。
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> Range("A6").Address Then Exit Sub
    Application.EnableEvents = False
    For Each c In Range("A1:A5")
        If c.Value = Range("A6") Then
            MyRow = c.Row
            If MyRow < c.Row Then
                MyRow = c.Row
            Else
                MyRow = MyRow
            End If
        End If
    Next c
    If IsEmpty(MyRow) Then
        MsgBox ("該当する社名がありません。")
    Else
        Range("B6").Value = Cells(MyRow, 4).Value
    End If
    Application.EnableEvents = True
End Sub


 （川野鮎太郎）
　　川野鮎太郎さま　早速ご教授いただきありがとうございました。
　いつも川野様の明解等には敬服しています。整頓された表に書き換えて
　までご指示をいただき誠に感激です。
　このデータは他のシートから転記しておりますので、Ａ列に社名が入ったら
　Ｂ列に表示したいので、マクロで良かったです。
　本当に助かりありがとうございました。これで十分ですが、念のため
　　　※ついでに、チェンジイベントの場合です。
　はどのような時にしようするのですか？
　ＶＢＡはまだ浅学でよく解りませんご指導いただければ幸いです。
　　（どらきち）
　川野さま
1つ質問があります。
上記のマクロの場合、Ｂ6のセルに上段にないＨ社を入れて実行しますと
実行時エラー　’13’
　　Range("B6").Value = Cells(MyRow, 4).Value
　が型が一致しませんとなり　”該当する社名がありません。”は表示されません
　どうしてでしょうか、お手数かけますがご指導お願いします。
　　　（どらきち） 

 (*'ω'*)......ん?　いくつか疑問点(^_^A;
 (1)＞Ａ列に社名が入ったらＢ列に表示したいので、マクロで良かったです
 　　↑数式でもA列に社名を入れたらB列に値が出ますが(^_^A;


 (2)＞Ｂ6のセルに上段にないＨ社を入れて実行しますと実行時エラー　’13’
 　　↑入れるのはA列ですよね。　
 　　A6にH社を入れたら”該当する社名がありません。”って出ますけど(^_^A;


 ＞＞ついでに、チェンジイベントの場合です。＞はどのような時にしようするのですか？
 シートタブを右クリックして、コードの表示をクリック
 VBEの画面が出るので、そこにコードをコピペです。
 ※ただしA6セル限定でやってますので、実際のレイアウトに合わせてコードを書き換える必要があります。
 （川野鮎太郎）
川野さま
お手数をかけて申し訳ございません。
会社は３０社ぐらいありますから、マクロは次のようにしましたが
変数の設定がいけないでしょうか、上記に出てきた会社はＯＫですが
初めての会社は　実行時エラー　になってしまいます。

Sub TEST() 

  Dim n As Integer
    n = Range("A10000").End(xlUp).Row
  Dim C, MyRow As String
  For Each C In Range(Cells(2, 1), Cells(n - 1, 1))
    If C.Value = Cells(n, 1) Then
        MyRow = C.Row
        If MyRow < C.Row Then
            MyRow = C.Row
        Else
            MyRow = MyRow
        End If
    End If
  Next C
  If IsEmpty(MyRow) Then
    MsgBox ("該当する社名がありません。")
  Else
     Cells(n, 2).Value = Cells(MyRow, 4).Value
 End If
End Sub

配列数式は、1セルには対応できますが、次のように空白の場合の
=IF(A6="","",IF(ISNA(MATCH(A6,$A$1:A5,0)),"該当なし",INDEX($A$1:D5,MAX(($A$1:A5=A6)*ROW($A$1:A5)),4)))
配列数式がつくれない（これでは間違いですものね）ので、マクロでと思います。
上記のマクロどこがいけないでしょうか再度お願いします。
（どらきち） 

 MyRowがEmptyじゃないからです。実際に何なのかはステップ実行で確認してください。　(wizik)

 ちょっと時間が出来たので作ってみました。
よかったら参考にして下さい。v(=∩_∩=)v
（SoulMan）
最初はFindを使った場合です。シートモジュールに記述します。
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim C As Range
Dim MyRow As Range
Dim MyTbl As Range
Dim FstAdd As String
If Target.Column <> 1 Then Exit Sub
If Target.Row < 2 Then Exit Sub
If Target.Count > 1 Then Exit Sub
If IsEmpty(Target.Value) Then Exit Sub
With Me
    If Target.Row <> .Range("A65536").End(xlUp).Row Then Exit Sub
    Set MyTbl = .Range("A1", .Range("A65536").End(xlUp).Offset(-1))
End With
Application.EnableEvents = False
 Set C = MyTbl.Find(What:=Target.Value, LookIn:=xlValues, LookAt:=xlWhole, _
                            SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=True)
If Not C Is Nothing Then
    FstAdd = C.Address
    If Not IsEmpty(C.Offset(, 3).Value) Then
        Target.Offset(, 1).Value = C.Offset(, 3).Value
    Else
        Do
            Set C = MyTbl.FindPrevious(C)
            If Not IsEmpty(C.Offset(, 3).Value) Then
                Target.Offset(, 1).Value = C.Offset(, 3).Value
                Exit Do
            End If
        Loop While C.Address <> FstAdd
        If C.Address = FstAdd Then
            MsgBox "対象となる数値がありません。"
            Target.Offset(, 1).Value = Empty
        End If
    End If
Else
    MsgBox Target.Value & "は、ありません。"
End If
Application.EnableEvents = True
Set MyTbl = Nothing
End Sub
次は配列を使って処理する場合です。
標準モジュールに記述します。
Option Explicit
Sub てすと()
Dim MyA As Variant, MyB As Double
Dim i As Long
Dim MyFlag As Boolean
Dim MyTbl As Range, MyTblA As Range
    With Worksheets("Sheet1")
        Set MyTblA = .Range("A65536").End(xlUp)
        Set MyTbl = .Range("A1", MyTblA)
        MyA = MyTbl.Resize(, 4).Value
        MyFlag = False
        For i = UBound(MyA, 1) - 1 To LBound(MyA, 1) Step -1
            If MyA(UBound(MyA, 1), 1) = MyA(i, 1) Then
                MyFlag = True
                If Not IsEmpty(MyA(i, 4)) Then
                    MyB = MyA(i, 4)
                    Exit For
                End If
            End If
        Next
        If MyFlag = False Then
            MsgBox MyA(UBound(MyA, 1), 1) & "は、ありません。"
        Else
            If MyB = 0 Then
                MsgBox "対象となる数値がありません。"
                MyTblA.Offset(, 1).Value = Empty
            Else
                MyTblA.Offset(, 1).Value = MyB
            End If
        End If
    End With
Erase MyA
Set MyTbl = Nothing
Set MyTblA = Nothing
End Sub
最後にFor　Eachを使った場合です。
これも標準モジュールに記述します。
Sub TEST()
Dim C As Range, MyRow As Long
Dim MyTbl As Range
Dim MyKey As String
Dim MyFlag As Boolean
With Sheet1
Set MyTbl = .Range("A65536").End(xlUp)
MyKey = MyTbl.Value
    For Each C In .Range("A1", MyTbl.Offset(-1))
      If C.Value = MyKey Then
        MyFlag = True
        If Not IsEmpty(C.Offset(, 3)) Then
            MyRow = C.Row
        End If
      End If
    Next C
    If MyRow > 0 Then
        MyTbl.Offset(, 1).Value = .Cells(MyRow, 4).Value
    Else
        If MyFlag = False Then
          MsgBox MyKey & "は、ありません。"
        Else
          MsgBox "対象となる数値がありません。"
        End If
    End If
End With
Set MyTbl = Nothing
End Sub


 エラーの原因はwizikさんのご指摘のように、MyRowがEmptyじゃないからですね。


 これは私の責任で、変数を定義してなかったからEmptyで良かったんですが、
 ちゃんと、Dim MyRow As Longで定義すればエラーになりますね。
 これならOKみたいです。　失礼しました。
Sub TEST()
Dim n As Integer
Dim C As Range
Dim MyRow As Long
n = Range("A10000").End(xlUp).Row
For Each C In Range(Cells(2, 1), Cells(n - 1, 1))
    If C.Value = Cells(n, 1) Then
        MyRow = C.Row
        If MyRow < C.Row Then
            MyRow = C.Row
        Else
            MyRow = MyRow
        End If
    End If
Next C
If MyRow = 0 Then
    MsgBox ("該当する社名がありません。")
Else
     Cells(n, 2).Value = Cells(MyRow, 4).Value
End If
End Sub


 ただ、行が多いと処理が遅いので、下から順番にFor NextでStep -1とした方が
 早いかもしれません。


 って、ここまで書いてManちゃんのを[壁]_･)チラッっと見たら、2番目がそうなってるのかな・・・。
 （川野鮎太郎）


 ワークシート関数のMatch関数を使ってみました。
Sub TEST()
Dim n As Long, i As Long
n = Range("A10000").End(xlUp).Row
On Error GoTo ErrorHandler
If Application.WorksheetFunction.Match(Cells(n, 1).Value, Range("A1:A" & n - 1), 0) Then
    For i = n - 1 To 1 Step -1
        If Cells(n, 1).Value = Cells(i, 1).Value Then
            Cells(n, 2).Value = Cells(i, 4).Value
            Exit Sub
        End If
    Next i
Else
ErrorHandler:
    MsgBox ("該当する社名がありません。")
End If
End Sub


 ※これは最初に提示した計算式をマクロにしたようなものです(^_^A;


 （川野鮎太郎）

 (wizik) さんご指摘ありがとうございました。
（SoulMan）さん、川野さん貴重な時間をさいてご指導いただきありがとうございます。
川野さん両方とも上手く作動いたしました。６０半ばの年齢でＶＢＡに挑戦していますがなかなマスターできません。３日ほど考えましたがダメでしたが本当に助かりました。誠にありがとうございました。

（SoulMan）さん　
ご丁寧なご指導ありがとうございました。最初川野さんに指導いただきましたので
そちらが理解し易かったのでそれで解決いたしました。
貴方のマクロもゆっくり勉強させていただきます。
ありがとうございました。
　　　　　　　　　　　　　　　　　　　　解決いたしました。（どらきち）

コメント返信：

[ 一覧(最新更新順) ]

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