Excel VBA質問箱 IV

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

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


38188 / 76732 ←次へ | 前へ→

【43687】Re:条件2個つきのセルの色付けについて
回答  Hirofumi  - 06/10/22(日) 23:05 -

引用なし
パスワード
   上位9人の見解の相異かな?
同点の場合が有るので、人名rも入るのかな?

Option Explicit

Public Sub DataMatch()

  '科目1のデータ列数(B列〜C列)
  Const clngColumns1 As Long = 2
  '科目1の「氏名」の有る列位置(基準位置からの列Offset「C列」)
  Const clngKeys1 As Long = 0
  '科目2のデータ列数(F列〜G列)
  Const clngColumns2 As Long = 2
  '科目2の「氏名」の有る列位置(基準位置からの列Offset「G列」)
  Const clngKeys2 As Long = 0
  '出力するRankの最大値
  Const clngLimit As Long = 9
  
  Dim i As Long
  Dim rngList1 As Range, rngList2 As Range
  Dim vntList1 As Variant, vntList2 As Variant
  Dim lngRows1 As Long, lngRows2 As Long
  Dim dicIndex As Object
  Dim lngColor As Long
  Dim lngCount As Long
  Dim lngRank As Long
  Dim lngMark As Long
  Dim strProm As String

  '科目1データシートのA1を基準とします
  Set rngList1 = Worksheets("Sheet1").Cells(6, "B")
  
  '科目2データシートのA1を基準とする
  Set rngList2 = Worksheets("Sheet1").Cells(6, "F")
  
  '画面更新を停止
'  Application.ScreenUpdating = False
  
  '科目1の基準に就いて
  If Not GetBasicData(rngList1, lngRows1, clngColumns1, clngKeys1, vntList1) Then
    strProm = rngList1.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  '科目2基準に就いて
  If Not GetBasicData(rngList2, lngRows2, clngColumns2, clngKeys2, vntList2) Then
    strProm = rngList2.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  'Dictionaryオブジェクトを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  '科目1の基準に就いて
  With dicIndex
    'Rankの初期値
    lngRank = 1
    '人数の初期値
    lngMark = 1
    '科目1の上位者をDictionaryに登録
    .Item(vntList1(1, 1)) = 1
    For i = 2 To lngRows1
      '人数を更新
      lngMark = lngMark + 1
      '点数が前と違った場合
      If vntList1(i, 2) <> vntList1(i - 1, 2) Then
        'Rankの更新
        lngRank = lngMark
      End If
      '指定Rankの者までを登録
      If lngRank <= clngLimit Then
        .Item(vntList1(i, 1)) = i
      Else
        Exit For
      End If
    Next i
  End With
  
  '科目2の基準に就いて
  With dicIndex
    'Rankの初期値
    lngRank = 1
    '人数の初期値
    lngMark = 1
    '科目1の上位者名と同じならBuckColorを変更
    If .Exists(vntList2(1, 1)) Then
      'ColorIndexを更新
      lngColor = 33 + (lngCount Mod 16)
      '科目1に色付け
      rngList1.Offset(.Item(vntList2(1, 1))).Interior.ColorIndex = lngColor
      '科目2に色付け
      rngList2.Offset(1).Interior.ColorIndex = lngColor
      '次のColorIndexに
      lngCount = lngCount + 1
    End If
    For i = 2 To lngRows2
      '人数を更新
      lngMark = lngMark + 1
      '点数が前と違った場合
      If vntList2(i, 2) <> vntList2(i - 1, 2) Then
        'Rankの更新
        lngRank = lngMark
      End If
      '指定Rankの者までを登録
      If lngRank <= clngLimit Then
        .Item(vntList1(i, 1)) = i
        If .Exists(vntList2(i, 1)) Then
          'ColorIndexを更新
          lngColor = 33 + (lngCount Mod 16)
          '科目1に色付け
          rngList1.Offset(.Item(vntList2(i, 1))).Interior.ColorIndex = lngColor
          '科目2に色付け
          rngList2.Offset(i).Interior.ColorIndex = lngColor
          '次のColorIndexに
          lngCount = lngCount + 1
        End If
      Else
        Exit For
      End If
    Next i
  End With
  
  
  '科目1のシートの順位を復帰
  DataRestore rngList1, lngRows1, clngColumns1
  
  '科目2のシートの順位を復帰
  DataRestore rngList2, lngRows2, clngColumns2

  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set dicIndex = Nothing
  Set rngList1 = Nothing
  Set rngList2 = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Private Function GetBasicData(rngList As Range, _
                lngRows As Long, _
                lngColumns As Long, _
                lngKeys As Long, _
                vntData As Variant) As Boolean

  Dim i As Long
  Dim lngNumb() As Long
  
  '基準に就いて
  With rngList
    '行数を取得
    lngRows = .Offset(Rows.Count - .Row, lngKeys).End(xlUp).Row - .Row
    'データが無ければFunctionを抜ける(戻り値=False)
    If lngRows <= 0 Then
      Exit Function
    End If
    '復帰用整列Keyを作成
    ReDim lngNumb(1 To lngRows, 1 To 1)
    For i = 1 To lngRows
      lngNumb(i, 1) = i
    Next i
    '復帰用Keyの出力列を挿入
    .Offset(1, lngColumns).EntireColumn.Insert
    '復帰用Keyの出力
    .Offset(1, lngColumns).Resize(lngRows).Value = lngNumb
    'データをlngKeys1列で整列
    .Offset(1).Resize(lngRows, lngColumns + 1).Sort _
      Key1:=.Offset(1, lngKeys + 1), Order1:=xlDescending, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '比較用配列にデータを取得
    vntData = .Offset(1, lngKeys).Resize(lngRows + 1, 2).Value
  End With
  
  GetBasicData = True

End Function

Private Sub DataRestore(rngList As Range, lngRows As Long, lngColumns As Long)

  With rngList
    '元データ順位を復帰
    .Offset(1).Resize(lngRows, lngColumns + 1).Sort _
      Key1:=.Offset(1, lngColumns), Order1:=xlAscending, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '復帰用Key列を削除
    .Offset(1, lngColumns).EntireColumn.Delete
  End With

End Sub

0 hits

【43672】条件2個つきのセルの色付けについて ミク 06/10/22(日) 17:54 質問
【43673】Re:条件2個つきのセルの色付けについて かみちゃん 06/10/22(日) 17:57 発言
【43677】Re:条件2個つきのセルの色付けについて ミク 06/10/22(日) 18:15 質問
【43678】Re:条件2個つきのセルの色付けについて かみちゃん 06/10/22(日) 18:40 発言
【43680】Re:条件2個つきのセルの色付けについて ミク 06/10/22(日) 19:26 質問
【43685】Re:条件2個つきのセルの色付けについて かみちゃん 06/10/22(日) 20:31 発言
【43686】Re:条件2個つきのセルの色付けについて ponpon 06/10/22(日) 23:03 発言
【43688】Re:条件2個つきのセルの色付けについて ichinose 06/10/23(月) 8:00 発言
【43737】Re:条件2個つきのセルの色付けについて ミク 06/10/24(火) 12:41 お礼
【43681】Re:条件2個つきのセルの色付けについて ichinose 06/10/22(日) 19:30 発言
【43682】Re:条件2個つきのセルの色付けについて ミク 06/10/22(日) 19:52 質問
【43683】Re:条件2個つきのセルの色付けについて ichinose 06/10/22(日) 20:06 発言
【43676】Re:条件2個つきのセルの色付けについて Kein 06/10/22(日) 18:12 回答
【43687】Re:条件2個つきのセルの色付けについて Hirofumi 06/10/22(日) 23:05 回答

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