Excel VBA質問箱 IV

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

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


18128 / 76738 ←次へ | 前へ→

【64053】Re:ご協力お願いします。
回答  Hirofumi  - 10/1/13(水) 19:05 -

引用なし
パスワード
   基本的にコードを変えてません
変更した所は、
各パラメタ(Constで定義されている定数と比較Keyの位置)
定数項目2個追加(差異列の位置、前回は受注額の後ろとしていた物を独立に)
変数を2個追加(差異計算用)
データ復帰に使うKey列を作業列として、L列とX列を使用(前回は先頭No列)

尚、前月Listの先頭に「担当課名」が有りませんが善いのですね?
 「※A〜K列」と成っているのにレスでは「A〜J列」しか有りませんが?
 もし先頭列に「担当課名」が在るようなら、「★???」行を活かして下の行を削除して下さい

Option Explicit
Option Compare Text

Public Sub DataMatch_2()

  '前月のデータ列数(A列〜K列)
  Const clngColumns1 As Long = 11
  '受注額の列位置を指定(基準セルからの列Offset)
'  Const clngItems1 As Long = 7 '★???
  Const clngItems1 As Long = 6
  '差異の列位置を指定(基準セルからの列Offset)
'  Const clngDiffer1 As Long = 9 '★???
  Const clngDiffer1 As Long = 8
  
  '今月のデータ列数(M列〜W列)
  Const clngColumns2 As Long = 11
  '受注額の列位置を指定(基準セルからの列Offset)
  Const clngItems2 As Long = 7
  '差異の列位置を指定(基準セルからの列Offset)
  Const clngDiffer2 As Long = 9
  
  Dim rngList1 As Range
  Dim vntList1 As Variant
  Dim lngRows1 As Long
  Dim lngComp1 As Long
  Dim vntKeys1 As Variant
  Dim vntResult1 As Variant
  Dim vntTmp1 As Variant
  
  Dim rngList2 As Range
  Dim vntList2 As Variant
  Dim lngRows2 As Long
  Dim lngComp2 As Long
  Dim vntKeys2 As Variant
  Dim vntResult2 As Variant
  Dim vntTmp2 As Variant
  
  Dim lngMatch As Long
  Dim strProm As String

  '前月データシートのA1を基準とします
  Set rngList1 = ActiveSheet.Range("A1")
  
  '今月データシートのA1を基準とする
  Set rngList2 = ActiveSheet.Range("M1")
  
  '前月の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
'  vntKeys1 = Array(2, 3) '★???
  vntKeys1 = Array(1, 2)
  '今月の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'M列=0、O列=2、Q列=4
  vntKeys2 = Array(2, 3)
  
  '前月の比較データを保持する配列を確保
  ReDim vntList1(0 To UBound(vntKeys1))
  '今月の比較データを保持する配列を確保
  ReDim vntList2(0 To UBound(vntKeys1))
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '前月の基準に就いて
  If Not GetBasicData(rngList1, lngRows1, clngColumns1, vntKeys1, vntList1) Then
    strProm = rngList1.Parent.Name & "にデータが有りません"
    GoTo Wayout
  Else
    ReDim vntResult1(1 To lngRows1, 1 To 2)
  End If
  
  '今月基準に就いて
  If Not GetBasicData(rngList2, lngRows2, clngColumns2, vntKeys2, vntList2) Then
    strProm = rngList2.Parent.Name & "にデータが有りません"
    GoTo Wayout
  Else
    ReDim vntResult2(1 To lngRows2, 1 To 2)
  End If
  
  '前月のシートの比較位置
  lngComp1 = 1
  '今月のシートの比較位置
  lngComp2 = 1
  '前月のシート若しくは、今月のシートが最終行に達するまで繰り返し
  Do Until lngComp1 > lngRows1 And lngComp2 > lngRows2
    '各列のデータを比較
    lngMatch = DataCompare(vntList1, lngComp1, vntList2, lngComp2)
    '比較結果に就いて
    Select Case lngMatch
      Case Is = 0 'Matchiした場合
        '所持金を比較
        vntTmp1 = rngList1.Offset(lngComp1, clngItems1).Value
        vntTmp2 = rngList2.Offset(lngComp2, clngItems2).Value
        If vntTmp1 <> vntTmp2 Then
          vntResult1(lngComp1, 1) = "金額変更"
          vntResult1(lngComp1, 2) = vntTmp2 - vntTmp1
          vntResult2(lngComp2, 1) = "金額変更"
          vntResult2(lngComp2, 2) = vntTmp2 - vntTmp1
        End If
        '前月、今月のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
        lngComp2 = lngComp2 + 1
      Case Is = -1 '前月の固有値の場合
        vntResult1(lngComp1, 1) = "削除"
        '前月のシートの比較位置を更新
        lngComp1 = lngComp1 + 1
      Case Is = 1 '今月の固有値の場合
        vntResult2(lngComp2, 1) = "追加"
        '今月のシートの比較位置を更新
        lngComp2 = lngComp2 + 1
    End Select
  Loop
  
  '結果を出力
  rngList1.Offset(1, clngDiffer1).Resize(lngRows1, 2) = vntResult1
  rngList2.Offset(1, clngDiffer2).Resize(lngRows2, 2) = vntResult2
  
  '前月のシートの順位を復帰
  DataRestore rngList1, lngRows1, clngColumns1
  '今月のシートの順位を復帰
  DataRestore rngList2, lngRows2, clngColumns2

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

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

  Dim i As Long
  
  '基準に就いて
  With rngList
    '行数を取得
    lngRows = .Offset(Rows.Count - .Row, vntKeys(0)).End(xlUp).Row - .Row
    'データが無ければFunctionを抜ける(戻り値=False)
    If lngRows <= 0 Then
      Exit Function
    End If
    '復帰用Keyの出力列を挿入
    .Offset(1, lngColumns).EntireColumn.Insert
    '復帰用整列Keyを作成
    With .Offset(1, lngColumns)
      .Value = 1
      .Resize(lngRows).DataSeries _
          Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
          Step:=1, Trend:=False
    End With
    'データをvntKeys1列で整列
    For i = UBound(vntKeys) To 0 Step -1
      DataSort .Offset(1).Resize(lngRows, lngColumns + 1), .Offset(1, vntKeys(i))
    Next i
    '比較用配列にデータを取得
    For i = 0 To UBound(vntKeys)
      vntData(i) = .Offset(1, vntKeys(i)).Resize(lngRows + 1).Value
    Next i
  End With
  
  GetBasicData = True

End Function

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

  With rngList
    '元データ順位を復帰
    DataSort .Offset(1).Resize(lngRows, lngColumns + 1), .Offset(1, lngColumns)
    '復帰用Key列を削除
    .Offset(, lngColumns).EntireColumn.Delete
  End With

End Sub

Private Sub DataSort(rngScope As Range, _
          rngKey As Range, _
          Optional lngOrientation As Long = xlTopToBottom)

  rngScope.Sort _
      Key1:=rngKey, Order1:=xlAscending, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=lngOrientation, SortMethod:=xlStroke

End Sub

Private Function DataCompare(vntKeys1 As Variant, lngPos1 As Long, _
            vntKeys2 As Variant, lngPos2 As Long) As Long

'  データの大小比較

  Dim i As Long
  Dim lngMax As Long
  
  If lngPos1 > UBound(vntKeys1(0), 1) - 1 Then
    DataCompare = 1
    Exit Function
  End If
  If lngPos2 > UBound(vntKeys2(0), 1) - 1 Then
    DataCompare = -1
    Exit Function
  End If
    
  lngMax = UBound(vntKeys1, 1)
  
  For i = 0 To lngMax
    If vntKeys1(i)(lngPos1, 1) <> vntKeys2(i)(lngPos2, 1) Then
      Exit For
    End If
  Next i
  
  If i > lngMax Then
    DataCompare = 0
  Else
    If vntKeys1(i)(lngPos1, 1) < vntKeys2(i)(lngPos2, 1) Then
      DataCompare = -1
    Else
      DataCompare = 1
    End If
  End If
  
End Function
0 hits

【64046】ご協力お願いします。 初心者 10/1/12(火) 22:19 質問
【64047】Re:ご協力お願いします。 Hirofumi 10/1/12(火) 23:49 回答
【64048】Re:ご協力お願いします。 Hirofumi 10/1/13(水) 0:22 回答
【64052】Re:ご協力お願いします。 初心者 10/1/13(水) 16:57 質問
【64053】Re:ご協力お願いします。 Hirofumi 10/1/13(水) 19:05 回答
【64054】Re:ご協力お願いします。 初心者 10/1/13(水) 20:38 お礼
【64055】Re:ご協力お願いします。 ご参考 10/1/13(水) 23:13 発言
【64060】Re:ご協力お願いします。 Hirofumi 10/1/14(木) 12:25 回答
【64065】Re:ご協力お願いします。 初心者 10/1/14(木) 22:41 質問
【64066】Re:ご協力お願いします。 Hirofumi 10/1/14(木) 23:37 発言
【64067】Re:ご協力お願いします。 初心者 10/1/15(金) 8:52 発言
【64068】Re:ご協力お願いします。 Hirofumi 10/1/15(金) 13:05 発言
【64069】Re:ご協力お願いします。 Hirofumi 10/1/15(金) 13:13 発言
【64074】Re:ご協力お願いします。 初心者 10/1/16(土) 22:29 質問
【64075】Re:ご協力お願いします。 かみちゃん 10/1/16(土) 22:34 発言
【64076】Re:ご協力お願いします。 Hirofumi 10/1/16(土) 23:15 回答
【64077】Re:ご協力お願いします。 Hirofumi 10/1/16(土) 23:27 回答
【64078】Re:ご協力お願いします。 Hirofumi 10/1/16(土) 23:45 回答
【64079】Re:ご協力お願いします。 初心者 10/1/17(日) 1:01 発言
【64080】Re:ご協力お願いします。 Hirofumi 10/1/17(日) 8:56 回答
【64081】Re:ご協力お願いします。 Hirofumi 10/1/17(日) 9:47 回答
【64085】Re:ご協力お願いします。 初心者 10/1/17(日) 12:41 発言
【64086】Re:ご協力お願いします。 Hirofumi 10/1/17(日) 16:10 回答
【64088】Re:ご協力お願いします。 初心者 10/1/17(日) 23:30 発言
【64089】Re:ご協力お願いします。 Hirofumi 10/1/18(月) 7:04 回答
【64090】Re:ご協力お願いします。 Hirofumi 10/1/18(月) 7:16 発言
【64102】Re:ご協力お願いします。 初心者 10/1/19(火) 9:26 お礼
【64082】Re:ご協力お願いします。 かみちゃん 10/1/17(日) 10:01 発言

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