Excel VBA質問箱 IV

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

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


46918 / 76732 ←次へ | 前へ→

【34781】Re:データ集計について
回答  Hirofumi  - 06/2/12(日) 13:03 -

引用なし
パスワード
   >つまり、抽出した表のX,Y軸の項目は決まってまして、元データは
>その項目がランダムに入力されます 項目の無いものは入力されません

「項目の無いものは入力されません」と言うのが、「項目の無い物は、カウントしません」
の意味なら、以下の様でも善いかも?(余り速く無いけど?)

Option Explicit

Public Sub Sample()

  Dim i As Long
  Dim lngRows As Long
  Dim lngRow As Long
  Dim lngColumn As Long
  Dim rngList As Range
  Dim vntData As Variant
  Dim rngResult As Range
  Dim vntResult As Variant
  Dim vntRows As Variant
  Dim vntColumns As Variant
  Dim strProm As String
  
  'Sheet1のListの左上隅セル位置を基準として設定
  Set rngList = Worksheets("Sheet1").Cells(1, "A")
  With rngList
    'データ行数を取得
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
    'データが無い場合
    If lngRows <= 1 And .Value = "" Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'データを配列に取得
    vntData = .Resize(lngRows, 2).Value
  End With
  
  'Sheet2Listの左上隅セル位置を基準として設定(見出しの「a」の左、「い」の上のセル位置)
  Set rngResult = Worksheets("Sheet2").Cells(1, "A")
  With rngResult
    '行見出しの行数を取得
    lngRow = .Offset(65536 - .Row).End(xlUp).Row - .Row
    'データが有る場合
    If lngRow > 0 Then
      vntRows = .Offset(1).Resize(lngRow + 1).Value
    End If
    '列見出しの列数を取得
    lngColumn = .Offset(, 256 - .Column).End(xlToLeft).Column - .Column
    'データが有る場合
    If lngColumn > 0 Then
      vntColumns = .Offset(, 1).Resize(, lngColumn + 1).Value
    End If
    '結果出力用配列を確保
    ReDim vntResult(1 To lngRow, 1 To lngColumn)
  End With
  
  'カウントを集計
  For i = 1 To lngRows
    'A列の値をListの行見出しから探索する
    lngRow = GetRowPos(vntData(i, 1), vntRows)
    '値が合った場合
    If lngRow > 0 Then
      'B列の値をListの列見出しから探索する
      lngColumn = GetColumnPos(vntData(i, 2), vntColumns)
      '値が合った場合
      If lngColumn > 0 Then
        '結果配列にカウントする
        vntResult(lngRow, lngColumn) _
            = vntResult(lngRow, lngColumn) + 1
      End If
    End If
  Next i
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '結果を出力
  rngResult.Offset(1, 1).Resize(UBound(vntResult, 1), _
        UBound(vntResult, 2)).Value = vntResult
  
  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Private Function GetRowPos(vntKey As Variant, vntScope As Variant) As Long

  Dim i As Long
  Dim lngListEnd As Long
  
  '行見出しが無い場合
  If VarType(vntScope) = vbVariant Then
    Exit Function
  End If
  
  '行見出しの行数を取得
  lngListEnd = UBound(vntScope, 1) - 1
  
  For i = 1 To lngListEnd
    'もし、行見出しと探索Keyが合致したら戻り値として行位置を返す
    If StrComp(vntKey, vntScope(i, 1), vbTextCompare) = 0 Then
      GetRowPos = i
      Exit Function
    End If
  Next i
  
End Function

Private Function GetColumnPos(vntKey As Variant, vntScope As Variant) As Long

  Dim i As Long
  Dim lngListEnd As Long
  
  If VarType(vntScope) = vbVariant Then
    Exit Function
  End If
  
  lngListEnd = UBound(vntScope, 2) - 1
  
  For i = 1 To lngListEnd
    If StrComp(vntKey, vntScope(1, i), vbTextCompare) = 0 Then
      GetColumnPos = i
      Exit Function
    End If
  Next i
  
End Function

1 hits

【34631】データ集計について G-3 06/2/8(水) 16:04 質問
【34632】Re:データ集計について ぴかる 06/2/8(水) 16:15 発言
【34692】Re:データ集計について G-3 06/2/9(木) 21:11 お礼
【34635】Re:データ集計について Statis 06/2/8(水) 17:09 回答
【34694】Re:データ集計について G-3 06/2/9(木) 21:32 質問
【34782】Re:データ集計について Statis 06/2/12(日) 13:14 発言
【34696】Re:データ集計について Kein 06/2/9(木) 22:38 回答
【34759】Re:データ集計について G-3 06/2/11(土) 17:05 お礼
【34774】Re:データ集計について G-3 06/2/12(日) 10:22 質問
【34780】Re:データ集計について とまと 06/2/12(日) 12:23 回答
【34781】Re:データ集計について Hirofumi 06/2/12(日) 13:03 回答
【34785】Re:データ集計について Kein 06/2/12(日) 17:30 回答
【34788】Re:データ集計について G-3 06/2/12(日) 21:22 質問
【34790】Re:データ集計について Statis 06/2/13(月) 8:11 発言
【34850】Re:データ集計について G-3 06/2/14(火) 19:21 質問
【34865】Re:データ集計について とまと 06/2/14(火) 22:55 質問
【34867】Re:データ集計について Statis 06/2/15(水) 8:50 発言
【34868】Re:データ集計について G-3 06/2/15(水) 10:50 お礼

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