Excel VBA質問箱 IV

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

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


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

【16903】検索関数について教えてください。 お初 04/8/15(日) 17:47 質問[未読]
【16904】Re:検索関数について教えてください。 ichinose 04/8/15(日) 19:22 回答[未読]
【16905】Re:検索関数について教えてください。 Hirofumi 04/8/15(日) 20:26 回答[未読]
【16916】Re:検索関数について教えてください。 Hirofumi 04/8/16(月) 13:24 回答[未読]
【16940】Re:検索関数について教えてください。 お初 04/8/16(月) 19:38 お礼[未読]

【16903】検索関数について教えてください。
質問  お初  - 04/8/15(日) 17:47 -

引用なし
パスワード
   こんにちは。
現在、Book1のSheet1のA列とB列のデータが一致しているデータをカウントして
Sheet2のA列、B列、C列に自動入力されるようにしたいのですが、
どのようにすればよろしいでしょうか?
文章ではうまく説明できませんので、例文でご説明します。
例:
Sheet1
A列    B列
A1000    2004/08/01
A1000    2004/08/02
A1000    2004/08/02
A1033    2004/08/03
A1034    2004/08/03
Sheet2
A列 B列    C列    D列
   2004/08/01 2004/08/02 2004/08/03
A1000     1     2
A1033                 1
A1034                 1

とSheet1からsheet2へ上記のようにしたいのですが、どの用にすればよろしいでしょうか?
ご教授お願い致します。

【16904】Re:検索関数について教えてください。
回答  ichinose  - 04/8/15(日) 19:22 -

引用なし
パスワード
   ▼お初 さん:
こんばんは。

>現在、Book1のSheet1のA列とB列のデータが一致しているデータをカウントして
>Sheet2のA列、B列、C列に自動入力されるようにしたいのですが、
>どのようにすればよろしいでしょうか?
>文章ではうまく説明できませんので、例文でご説明します。
>例:
>Sheet1
>A列    B列
>A1000    2004/08/01
>A1000    2004/08/02
>A1000    2004/08/02
>A1033    2004/08/03
>A1034    2004/08/03
>Sheet2
>A列 B列    C列    D列
>   2004/08/01 2004/08/02 2004/08/03
>A1000     1     2
>A1033                 1
>A1034                 1
>
>とSheet1からsheet2へ上記のようにしたいのですが、どの用にすればよろしいでしょうか?
>ご教授お願い致します。

Sheet2のセルB2の場合です。

「=sumproduct((Sheet1!$A$1:$A$5=Sheet2!$A2)*(Sheet1!$B$1:$B$5=Sheet2!B$1))」

と入力して下さい。
残りのセルは、フィル操作を行って下さい。

このSumproduct関数のHelpを初めて見たときは、「なんの役に立つのだろう?」
と思いましたが、その後こういうサイトで複数条件に使用できるということが
わかりました。

【16905】Re:検索関数について教えてください。
回答  Hirofumi  - 04/8/15(日) 20:26 -

引用なし
パスワード
   こんな物かな?

Option Explicit

Public Sub AddUp()

  Dim i As Long
  Dim vntData As Variant
  Dim rngListTop As Range
  Dim rngScopeCol As Range
  Dim rngColItem As Range
  Dim lngColNum As Long
  Dim rngScopeRow As Range
  Dim rngRowItem As Range
  Dim lngRowNum As Long
  Dim lngFindCol As Long
  Dim lngFindRow As Long
  Dim lngOver As Long
  
  'デ−タの有るシートのデータを配列に取得
  'デ−タの左上隅のセルを設定
  If Not GetData(vntData, _
      Worksheets("Sheet1").Cells(1, "A")) Then
    Beep
    MsgBox "データが有りません"
    Exit Sub
  End If
  
  Application.ScreenUpdating = False
  
  '表を作るシートに就いて
  With Worksheets("Sheet2")
    'シートをクリア
    .Cells.Clear
    '表の先頭(左上隅のセル)を設定
    Set rngListTop = .Cells(1, "A")
  End With
  With rngListTop
    '列項目の初期値
    Set rngColItem = .Offset(, 1)
    lngColNum = 1
    '行項目の初期値
    Set rngRowItem = .Offset(1)
    lngRowNum = 1
    '表に転記
    For i = 1 To UBound(vntData, 1)
      'A列値の探索範囲の取得
      Set rngScopeRow = rngRowItem.Resize(lngRowNum)
      'A列値の行位置を探索
      lngFindRow = ItemSearch(vntData(i, 1), _
                rngScopeRow, lngOver, 1)
      '探索値が無かった場合(未発見)
      If lngFindRow = 0 Then
        '探索範囲行数を更新
        lngRowNum = lngRowNum + 1
        '挿入位置に行を挿入
        With .Offset(lngOver)
          .EntireRow.Insert
        End With
        '挿入行位置を発見行位置に設定
        lngFindRow = lngOver
        '行項目の初期値を再設定
        Set rngRowItem = .Offset(1)
        '挿入行位置にA列値を記入
        With .Offset(lngFindRow)
          .Value = vntData(i, 1)
        End With
      End If
      '日付の範囲を設定
      Set rngScopeCol = rngColItem.Resize(, lngColNum)
      '日付を探索
      lngFindCol = ItemSearch(CLng(vntData(i, 2)), _
                  rngScopeCol, lngOver, 1)
      '日付が無かった場合(未発見)
      If lngFindCol = 0 Then
        '探索範囲列数を更新
        lngColNum = lngColNum + 1
        '挿入位置に列を挿入
        With .Offset(, lngOver)
          .EntireColumn.Insert
        End With
        '挿入位置を発見位置に設定
        lngFindCol = lngOver
        '列項目の初期値を再設定
        Set rngColItem = .Offset(, 1)
        '挿入列位置に日付を記入
        With .Offset(, lngFindCol)
          '日付を記入
          .Value = CLng(vntData(i, 2))
        End With
      End If
      '発見した行列に値を記入
      With .Offset(lngFindRow, lngFindCol)
        .Value = .Value + 1
      End With
    Next i
    '書式を日付に設定
    rngScopeCol.NumberFormat = "yyyy/mm/dd"
  End With
  
  Set rngScopeCol = Nothing
  Set rngScopeRow = Nothing
  Set rngListTop = Nothing
  Set rngColItem = Nothing
  Set rngRowItem = Nothing
  
  Application.ScreenUpdating = True
  
  Beep
  MsgBox "処理が完了しました"
  
End Sub

Private Function GetData(vntData As Variant, _
            rngDataTop As Range) As Boolean
  
  Dim rngScope As Range
  
  Set rngScope = rngDataTop.CurrentRegion
  
  With rngScope
    'もし、データが有る場合
    If .Columns.Count >= 1 And .Rows.Count >= 1 Then
      'wksDataのデータを配列に取得
      vntData = .Value
      'データ取得成功を戻す
      GetData = True
    End If
  End With
  
  Set rngScope = Nothing
  
End Function

Private Function ItemSearch(vntKey As Variant, _
            rngScope As Range, _
            Optional lngOver As Long, _
            Optional lngCollation As Long = 1) As Long

  Dim vntFind As Variant
  Dim lngDataTop As Long
  
  If rngScope Is Nothing Then
    lngOver = 1
    Exit Function
  End If
  
  'Matchによる二分探索
  vntFind = Application.Match(vntKey, rngScope, lngCollation)
  'もし、エラーで無いなら
  If Not IsError(vntFind) Then
    'もし、Key値と探索位置の値が等しいなら
    If vntKey = rngScope.Cells(vntFind).Value Then
      '戻り値として、位置を代入
      ItemSearch = vntFind
    End If
    'Key値を超える最小値のある行
    lngOver = vntFind + 1
  Else
    lngOver = 1
  End If
  
End Function

【16916】Re:検索関数について教えてください。
回答  Hirofumi  - 04/8/16(月) 13:24 -

引用なし
パスワード
   Dictionaryオブジェクトが使えるならこちらの方が早いかも?

Option Explicit

Public Sub AddUp2()

  Dim i As Long
  Dim j As Long
  Dim lngRow As Long
  Dim lngCol As Long
  Dim dicRowIndex As Object
  Dim dicColIndex As Object
  Dim vntData As Variant
  Dim vntResult As Variant
  Dim vntItem() As Variant
  
  'デ−タの有るシートのデータを配列に取得
  'デ−タの左上隅のセルを設定
  If Not GetData(vntData, _
      Worksheets("Sheet1").Cells(1, "A")) Then
    Beep
    MsgBox "データが有りません"
    Exit Sub
  End If
  
  '列Indexのオブジェクト変数dicColIndexに
  'Dictionaryのインスタンスを取得
  Set dicColIndex = CreateObject("Scripting.Dictionary")
  '行Indexのオブジェクト変数dicColIndexに
  'Dictionaryのインスタンスを取得
  Set dicRowIndex = CreateObject("Scripting.Dictionary")
  
  '番号(行)のIndexを作成
  With dicRowIndex
    j = 1
    '配列の最終行まで繰り返す
    For i = 1 To UBound(vntData, 1)
      '番号(行)のIndexにKeyが無い場合
      If Not .Exists(vntData(i, 1)) Then
        'Key(番号)、項目(vntResultの行位置)を追加
        .Add vntData(i, 1), j
        '重複なしの番号を取得
        ReDim Preserve vntItem(1 To j)
        vntItem(j) = vntData(i, 1)
        '行位置を更新
        j = j + 1
      End If
    Next i
  End With
  
  '結果用配列を確保
  ReDim vntResult(UBound(vntItem, 1), 0)
  '番号を結果用配列に転記
  For i = 1 To UBound(vntItem, 1)
    vntResult(i, 0) = vntItem(i)
  Next i
  '番号を保持する配列を破棄
  Erase vntItem
  
  '結果用配列に室名、データを転記
  With dicColIndex
    j = 1
    For i = 1 To UBound(vntData, 1)
      '日付のIndexに日付が有った時
      If .Exists(vntData(i, 2)) Then
        '結果配列の列位置を取得
        lngCol = .Item(vntData(i, 2))
      Else
        '日付のIndexに日付、列位置を追加
        .Add vntData(i, 2), j
        '結果配列の列を配列の値を保持したまま拡張
        ReDim Preserve vntResult(UBound(vntResult, 1), j)
        '結果配列の拡張位置に日付を代入
        vntResult(0, j) = vntData(i, 2)
        '結果配列の列位置を設定
        lngCol = j
        '結果配列の添え字の最大値を更新
        j = j + 1
      End If
      '結果用配列の行位置を取得
      lngRow = dicRowIndex.Item(vntData(i, 1))
      '結果配列の拡張位置に値を積算
      vntResult(lngRow, lngCol) _
          = vntResult(lngRow, lngCol) + 1
    Next i
  End With
  
  Set dicColIndex = Nothing
  Set dicRowIndex = Nothing
  
  Application.ScreenUpdating = False
  
  '結果用配列をSheet2に出力
  With Worksheets("Sheet2")
    .Cells.Clear
    lngRow = UBound(vntResult, 1) + 1
    lngCol = UBound(vntResult, 2) + 1
    '結果表の左上隅に就いて
    With .Cells(1, "A")
      With .Resize(lngRow, lngCol)
        '結果出力
        .Value = vntResult
        '行を番号順にソート
        .Sort Key1:=.Item(1), Order1:=xlAscending, _
            Header:=xlYes, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom, _
            SortMethod:=xlStroke
      End With
      With .Offset(, 1).Resize(, lngCol - 1)
        '書式を日付に設定
        .NumberFormat = "yyyy/mm/dd"
        '列を日付昇順にソート
        With .Resize(lngRow)
          .Sort Key1:=.Item(1), Order1:=xlAscending, _
              Header:=xlNo, OrderCustom:=1, _
              MatchCase:=False, Orientation:=xlLeftToRight, _
              SortMethod:=xlStroke
        End With
      End With
    End With
  End With
  
  Application.ScreenUpdating = True
  
  Beep
  MsgBox "処理が完了しました"
  
End Sub

Private Function GetData(vntData As Variant, _
            rngDataTop As Range) As Boolean
  
  Dim rngScope As Range
  
  Set rngScope = rngDataTop.CurrentRegion
  
  With rngScope
    'もし、データが有る場合
    If .Columns.Count >= 1 And .Rows.Count >= 1 Then
      'wksDataのデータを配列に取得
      vntData = .Value
      'データ取得成功を戻す
      GetData = True
    End If
  End With
  
  Set rngScope = Nothing
  
End Function

【16940】Re:検索関数について教えてください。
お礼  お初  - 04/8/16(月) 19:38 -

引用なし
パスワード
   ▼Hirofumi さん:
>Dictionaryオブジェクトが使えるならこちらの方が早いかも?
>
>Option Explicit
>
>Public Sub AddUp2()
>
>  Dim i As Long
>  Dim j As Long
>  Dim lngRow As Long
>  Dim lngCol As Long
>  Dim dicRowIndex As Object
>  Dim dicColIndex As Object
>  Dim vntData As Variant
>  Dim vntResult As Variant
>  Dim vntItem() As Variant
>  
>  'デ−タの有るシートのデータを配列に取得
>  'デ−タの左上隅のセルを設定
>  If Not GetData(vntData, _
>      Worksheets("Sheet1").Cells(1, "A")) Then
>    Beep
>    MsgBox "データが有りません"
>    Exit Sub
>  End If
>  
>  '列Indexのオブジェクト変数dicColIndexに
>  'Dictionaryのインスタンスを取得
>  Set dicColIndex = CreateObject("Scripting.Dictionary")
>  '行Indexのオブジェクト変数dicColIndexに
>  'Dictionaryのインスタンスを取得
>  Set dicRowIndex = CreateObject("Scripting.Dictionary")
>  
>  '番号(行)のIndexを作成
>  With dicRowIndex
>    j = 1
>    '配列の最終行まで繰り返す
>    For i = 1 To UBound(vntData, 1)
>      '番号(行)のIndexにKeyが無い場合
>      If Not .Exists(vntData(i, 1)) Then
>        'Key(番号)、項目(vntResultの行位置)を追加
>        .Add vntData(i, 1), j
>        '重複なしの番号を取得
>        ReDim Preserve vntItem(1 To j)
>        vntItem(j) = vntData(i, 1)
>        '行位置を更新
>        j = j + 1
>      End If
>    Next i
>  End With
>  
>  '結果用配列を確保
>  ReDim vntResult(UBound(vntItem, 1), 0)
>  '番号を結果用配列に転記
>  For i = 1 To UBound(vntItem, 1)
>    vntResult(i, 0) = vntItem(i)
>  Next i
>  '番号を保持する配列を破棄
>  Erase vntItem
>  
>  '結果用配列に室名、データを転記
>  With dicColIndex
>    j = 1
>    For i = 1 To UBound(vntData, 1)
>      '日付のIndexに日付が有った時
>      If .Exists(vntData(i, 2)) Then
>        '結果配列の列位置を取得
>        lngCol = .Item(vntData(i, 2))
>      Else
>        '日付のIndexに日付、列位置を追加
>        .Add vntData(i, 2), j
>        '結果配列の列を配列の値を保持したまま拡張
>        ReDim Preserve vntResult(UBound(vntResult, 1), j)
>        '結果配列の拡張位置に日付を代入
>        vntResult(0, j) = vntData(i, 2)
>        '結果配列の列位置を設定
>        lngCol = j
>        '結果配列の添え字の最大値を更新
>        j = j + 1
>      End If
>      '結果用配列の行位置を取得
>      lngRow = dicRowIndex.Item(vntData(i, 1))
>      '結果配列の拡張位置に値を積算
>      vntResult(lngRow, lngCol) _
>          = vntResult(lngRow, lngCol) + 1
>    Next i
>  End With
>  
>  Set dicColIndex = Nothing
>  Set dicRowIndex = Nothing
>  
>  Application.ScreenUpdating = False
>  
>  '結果用配列をSheet2に出力
>  With Worksheets("Sheet2")
>    .Cells.Clear
>    lngRow = UBound(vntResult, 1) + 1
>    lngCol = UBound(vntResult, 2) + 1
>    '結果表の左上隅に就いて
>    With .Cells(1, "A")
>      With .Resize(lngRow, lngCol)
>        '結果出力
>        .Value = vntResult
>        '行を番号順にソート
>        .Sort Key1:=.Item(1), Order1:=xlAscending, _
>            Header:=xlYes, OrderCustom:=1, _
>            MatchCase:=False, Orientation:=xlTopToBottom, _
>            SortMethod:=xlStroke
>      End With
>      With .Offset(, 1).Resize(, lngCol - 1)
>        '書式を日付に設定
>        .NumberFormat = "yyyy/mm/dd"
>        '列を日付昇順にソート
>        With .Resize(lngRow)
>          .Sort Key1:=.Item(1), Order1:=xlAscending, _
>              Header:=xlNo, OrderCustom:=1, _
>              MatchCase:=False, Orientation:=xlLeftToRight, _
>              SortMethod:=xlStroke
>        End With
>      End With
>    End With
>  End With
>  
>  Application.ScreenUpdating = True
>  
>  Beep
>  MsgBox "処理が完了しました"
>  
>End Sub
>
>Private Function GetData(vntData As Variant, _
>            rngDataTop As Range) As Boolean
>  
>  Dim rngScope As Range
>  
>  Set rngScope = rngDataTop.CurrentRegion
>  
>  With rngScope
>    'もし、データが有る場合
>    If .Columns.Count >= 1 And .Rows.Count >= 1 Then
>      'wksDataのデータを配列に取得
>      vntData = .Value
>      'データ取得成功を戻す
>      GetData = True
>    End If
>  End With
>  
>  Set rngScope = Nothing
>  
>End Function

ichinoseさん、Hirofumiさん
どうもありがとうございます。
できました。

私は初心者なので、ichinoseさんの関数の方で
行いました。
VBAが分かるようになるまではもう少し時間がかかりそうなので、
そのときはHirofumiさんのコードを参考にさせていただきます。

どうもありがとうございました。

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