Excel VBA質問箱 IV

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

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


22313 / 76734 ←次へ | 前へ→

【59804】Re:2bookの文字列を比較する
お礼  みみん  - 09/1/9(金) 3:50 -

引用なし
パスワード
   ▼Hirofumi さん:
ありがとうございます。
私にはかなり難しすぎました。
解説も丁寧に書いてくださっているので
調べて理解していきます。

>こんな事すると出来るかも?
>"旧.xlsx"、"新.xlsx"は開いてている物とします
>出力はマクロの或るBookのSheet3とします
>
>Option Explicit
>Option Compare Text
>
>Public Sub DataMatch2()
>
>'  固有データのチェック
>
>  '"旧"のデータ列数(C列〜D列)
>  Const clngColumns1 As Long = 2
>  '"新"のデータ列数(C列〜D列)
>  Const clngColumns2 As Long = 2
>  
>  Dim rngList1 As Range
>  Dim vntList1 As Variant
>  Dim lngRows1 As Long
>  Dim lngComp1 As Long
>  Dim vntKeys1 As Variant
>  Dim rngList2 As Range
>  Dim vntList2 As Variant
>  Dim lngRows2 As Long
>  Dim lngComp2 As Long
>  Dim vntKeys2 As Variant
>  Dim lngMatch As Long
>  Dim rngResult As Range
>  Dim lngWrite As Long
>  Dim strProm As String
>
>  '"旧"データシートのA1を基準とします
>  Set rngList1 = Workbooks("旧.xlsx").Worksheets("旧").Cells(1, "C")
>  
>  '"新"データシートのA1を基準とする
>  Set rngList2 = Workbooks("新.xlsx").Worksheets("新").Cells(1, "C")
>  
>  '出力シートの基準位置を設定
>  Set rngResult = ThisWorkbook.Worksheets("Sheet1").Cells(1, "A")
>  
>  '"旧"の比較列の列挙(基準セル位置からの列Offsetを列挙)
>  'C列=0、D列=1
>  vntKeys1 = Array(0, 1)
>  '"新"の比較列の列挙(基準セル位置からの列Offsetを列挙)
>  'C列=0、D列=1
>  vntKeys2 = Array(0, 1)
>  
>  '"旧"の比較データを保持する配列を確保
>  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
>  End If
>  
>  '"新"基準に就いて
>  If Not GetBasicData(rngList2, lngRows2, clngColumns2, vntKeys2, vntList2) Then
>    strProm = rngList2.Parent.Name & "にデータが有りません"
>    GoTo Wayout
>  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した場合
>        '出力行位置を更新
>        lngWrite = lngWrite + 1
>        '行を出力
>        With rngResult
>          rngList1.Offset(lngComp1).Resize(, clngColumns1).Copy _
>              Destination:=.Offset(lngWrite)
>          .Offset(lngWrite, clngColumns1).Value = "変更なし"
>        End With
>        '"新"のシートの比較位置を更新
>        lngComp2 = lngComp2 + 1
>        '"旧"のシートの比較位置を更新
>        lngComp1 = lngComp1 + 1
>      Case Is = -1 '"旧"の固有値の場合
>        '出力行位置を更新
>        lngWrite = lngWrite + 1
>        '行を出力
>        With rngResult
>          rngList1.Offset(lngComp1).Resize(, clngColumns1).Copy _
>              Destination:=.Offset(lngWrite)
>          .Offset(lngWrite, clngColumns1).Value = "削除"
>        End With
>        '"旧"のシートの比較位置を更新
>        lngComp1 = lngComp1 + 1
>      Case Is = 1 '"新"の固有値の場合
>        '出力行位置を更新
>        lngWrite = lngWrite + 1
>        '行を出力
>        With rngResult
>          rngList2.Offset(lngComp2).Resize(, clngColumns2).Copy _
>              Destination:=.Offset(lngWrite)
>          .Offset(lngWrite, clngColumns1).Value = "追加"
>        End With
>        '"新"のシートの比較位置を更新
>        lngComp2 = lngComp2 + 1
>    End Select
>  Loop
>  
>  '"旧"のシートの順位を復帰
>  DataRestore rngList1, lngRows1, clngColumns1
>  
>  '"新"のシートの順位を復帰
>  DataRestore rngList2, lngRows2, clngColumns2
>
>  strProm = "処理が完了しました"
>  
>Wayout:
>  
>  '画面更新を再開
>  Application.ScreenUpdating = True
>  
>  Set rngList1 = Nothing
>  Set rngList2 = Nothing
>  Set rngResult = 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
>  Dim lngNumb() 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を作成
>    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
>    'データを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(1, 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
>  
>  '比較位置がDataEndを超えた場合
>  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
>    
>  '1行の最大比較回数を取得(実際は0から始まる為、回数としては+1と成る)
>  lngMax = UBound(vntKeys1, 1)
>  
>  '1行のKeyを先頭から比較
>  For i = 0 To lngMax
>    'もし、Keyが不一致なら
>    If vntKeys1(i)(lngPos1, 1) <> vntKeys2(i)(lngPos2, 1) Then
>      'Forを抜ける
>      Exit For
>    End If
>  Next i
>  
>  'Keyが全て一致した場合(Forが全て回り終った場合、iはlngMax+1と成る)
>  If i > lngMax Then
>    '戻り値の値として、「等しい」を返す
>    DataCompare = 0
>  Else
>    'vntKeys1の値が、vntKeys2の値因り小さい場合
>    If vntKeys1(i)(lngPos1, 1) < vntKeys2(i)(lngPos2, 1) Then
>      '戻り値の値として、「小さい」を返す
>      DataCompare = -1
>    Else
>      '戻り値の値として、「大きい」を返す
>      DataCompare = 1
>    End If
>  End If
>  
>End Function
5 hits

【59795】2bookの文字列を比較する みみん 09/1/8(木) 21:02 質問
【59797】Re:2bookの文字列を比較する かみちゃん 09/1/8(木) 21:13 発言
【59798】Re:2bookの文字列を比較する みみん 09/1/8(木) 21:29 発言
【59799】Re:2bookの文字列を比較する n 09/1/8(木) 21:29 発言
【59801】Re:2bookの文字列を比較する みみん 09/1/8(木) 21:50 発言
【59802】Re:2bookの文字列を比較する Hirofumi 09/1/8(木) 22:47 発言
【59804】Re:2bookの文字列を比較する みみん 09/1/9(金) 3:50 お礼

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