Excel VBA質問箱 IV

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

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


18121 / 76732 ←次へ | 前へ→

【64054】Re:ご協力お願いします。
お礼  初心者 E-MAIL  - 10/1/13(水) 20:38 -

引用なし
パスワード
   早速のご返信有難うございました!!

早速動かしてみましたが、思ったとおりの結果が得られました。

ほんとすばらしいです。

自分なりに中身を理解したいと思います。

Hirofumiさん、有難うございました。


▼Hirofumi さん:
>基本的にコードを変えてません
>変更した所は、
>各パラメタ(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 発言

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