Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


3321 / 13646 ツリー ←次へ | 前へ→

【62912】複数の条件で抽出したい 秋刀魚 09/9/15(火) 16:50 質問[未読]
【62913】Re:複数の条件で抽出したい Jaka 09/9/15(火) 17:20 発言[未読]
【62914】Re:複数の条件で抽出したい Hirofumi 09/9/15(火) 18:00 回答[未読]
【62915】Re:複数の条件で抽出したい 秋刀魚 09/9/15(火) 21:50 お礼[未読]
【62920】Re:複数の条件で抽出したい kanabun 09/9/17(木) 12:07 発言[未読]
【62929】Re:複数の条件で抽出したい kanabun 09/9/18(金) 23:33 発言[未読]

【62912】複数の条件で抽出したい
質問  秋刀魚  - 09/9/15(火) 16:50 -

引用なし
パスワード
   こんにちは。
簡略化して、次のようなデータがあるとします。

  日付   コード データ
1 2009/2/5  3   リンゴ
2 2009/3/16  4   バナナ
3 2009/3/10  8   オレンジ
4 2009/4/3  3   リンゴ
5 2009/2/21  8   オレンジ
6 2009/7/4  3   リンゴ

日付もコードもばらばらなデータの中から、各コードの最も新しい日付のデータを
(ここでは2、3、6行)抽出したいのです。

お願いします。
それから、多分日付は重複しないかもしれません。

  

【62913】Re:複数の条件で抽出したい
発言  Jaka  - 09/9/15(火) 17:20 -

引用なし
パスワード
   帰るので簡単ですが、
重複無しのデータ部を作れば、
エクセル関数で
=SUMPRODUCT(MAX((C2:C7="リンゴ")*(A2:A7)))
とすれば、最新の日付が取れます。

【62914】Re:複数の条件で抽出したい
回答  Hirofumi  - 09/9/15(火) 18:00 -

引用なし
パスワード
   こんなのでは

ListはSheet1のA1から始まり、結果はSheet2に出力されます
Sheet1には、列見出しが有る物とします

Option Explicit

Public Sub Sample()

  '元々のデータ列数(A列〜C列)
  Const clngColumns As Long = 3
  '「コード」の有る列(A列のA列からの列Offset)
  Const clngGroup1 As Long = 1
  '「日付」の有る列(B列のA列からの列Offset)
  Const clngGroup2 As Long = 0
  
  Dim i As Long
  Dim lngRows As Long
  Dim lngTop As Long
  Dim lngWright As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim vntGroup As Variant
  Dim strProm As String

  'Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngList = Worksheets("Sheet1").Cells(1, "A")

  '結果出力の位置を設定
  Set rngResult = Worksheets("Sheet2").Cells(1, "A")
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, clngGroup1).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'データに連番を付与(最終列の後ろに)
    .Offset(, clngColumns).EntireColumn.Insert
    With .Offset(1, clngColumns)
      .Value = 1
      .Resize(lngRows).DataSeries _
          Rowcol:=xlColumns, Type:=xlLinear, _
          Date:=xlDay, Step:=1, Trend:=False
    End With
    'データを「コード」、「日付」列をKeyとして整列
    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(, clngGroup1), Order1:=xlAscending, _
        Key2:=.Offset(, clngGroup2), Order2:=xlDescending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '「コード」列データを配列に取得
    vntGroup = .Offset(1, clngGroup1).Resize(lngRows + 1).Value
  End With
  
  '注目値の位置を記録
  lngTop = 1
  '先頭データを出力
  For i = 2 To lngRows + 1
    '注目値と現在値が違った場合
    If vntGroup(lngTop, 1) <> vntGroup(i, 1) Then
      'データを転記
      lngWright = lngWright + 1
      rngList.Offset(lngTop).Resize(, clngColumns).Copy _
          Destination:=rngResult.Offset(lngWright)
      '注目値の位置を記録
      lngTop = i
    End If
  Next i

  'データ位置の復帰
  With rngList
    'データを「コード」、「日付」列をKeyとして整列
    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(, clngColumns), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '連番削除
    .Offset(, clngColumns).EntireColumn.Delete
  End With
  
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
   
  Set rngList = Nothing
  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

【62915】Re:複数の条件で抽出したい
お礼  秋刀魚  - 09/9/15(火) 21:50 -

引用なし
パスワード
   皆さん早速のレスありがとうございます。

まだ試していませんが、検討して結果をお知らせしたいと思います。

【62920】Re:複数の条件で抽出したい
発言  kanabun  - 09/9/17(木) 12:07 -

引用なし
パスワード
   ▼秋刀魚 さん:
こんにちは。

別法ですが、こんなのどうでしょうか
(結果は E1以降に出力しています)

Sub Try1()
  Dim v, s As String
  Dim i As Long
  Dim dic As Object
  Set dic = CreateObject("Scripting.Dictionary")
  With ActiveSheet
    v = .Range("A1", _
      .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 2).Value
    dic(v(1, 2)) = v(1, 1)
    For i = 2 To UBound(v)
     s = v(i, 2)
     If dic.Exists(s) Then
      If dic(s) < v(i, 1) Then dic(s) = v(i, 1) '大きいほうを記憶
     Else
      dic(s) = v(i, 1)
     End If
    Next
    .Range("E1").Resize(dic.Count, 2).Value = _
     Application.Transpose(Array(dic.Keys, dic.Items))
  End With
  Set dic = Nothing
End Sub

【62929】Re:複数の条件で抽出したい
発言  kanabun  - 09/9/18(金) 23:33 -

引用なし
パスワード
   ▼秋刀魚 さん:

上のサンプルは コードと日付のリストを書き出すものでしたが、
該当行を別シートに書き出すなら、(Try1を少し修正して)
こんな感じになります。

Sub Try2() '別シートへ抽出
  Dim r As Range
  Dim v, s As String, w
  Dim i As Long, y As Long, x As Long
  Dim dic As Object
  Set dic = CreateObject("Scripting.Dictionary")
  '元データ
  Set r = Worksheets(1).Range("A1").CurrentRegion
  x = r.Columns.Count
  v = r.Resize(, 2).Value
  y = UBound(v)
  '「コード」別最新日付行を検索
  For i = 2 To y
   s = v(i, 2)
   If dic.Exists(s) Then
     If v(dic(s), 1) < v(i, 1) Then dic(s) = i
   Else
     dic(s) = i
   End If
  Next
  ReDim w(1 To y, 1 To 1)
  w(1, 1) = "temp"
  For Each v In dic.Keys
    i = dic(v)
    w(i, 1) = i 'コード別最新日付行を配列に書き込む
  Next
  Worksheets(2).UsedRange.ClearContents
  With r.Item(1, x + 1).Resize(y)
    .Value = w        '作業列に
    .AutoFilter 1, ">=0"   '行番号のある行だけ抽出
    r.Copy Worksheets(2).Range("A1") '別シートに転記
    .AutoFilter
    .ClearContents
  End With
  Set dic = Nothing
End Sub

3321 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free