Excel VBA質問箱 IV

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

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


39606 / 76732 ←次へ | 前へ→

【42236】Re:処理時間の短縮
回答  Hirofumi  - 06/9/4(月) 19:42 -

引用なし
パスワード
   余りTestしていないので上手く無いかも?
尚、処理時間は幾らか速く成るかも?

"Sheets(1)"、"Sheets(2)"共に同一シート内で、A列&B列&C列&D列の値の重複が無い物とします

Option Explicit
Option Compare Text

Public Sub DataMatch()

'  同一データのチェック

  '"Sheets(1)"のデータ列数(A列〜E列)
  Const clngColumns1 As Long = 5
  '"Sheets(2)"のデータ列数(A列〜E列)
  Const clngColumns2 As Long = 5
  
  Dim i As Long
  Dim rngList1 As Range
  Dim lngEnd1 As Long
  Dim vntList1 As Variant
  Dim lngRow1 As Long
  Dim vntKeys1 As Variant
  Dim vntItems1 As Variant
  Dim rngList2 As Range
  Dim lngEnd2 As Long
  Dim vntList2 As Variant
  Dim lngRow2 As Long
  Dim vntKeys2 As Variant
  Dim vntItems2 As Variant
  Dim lngMatch As Long
  Dim rngResult As Range
  Dim lngCount As Long
  Dim strProm As String

  '"Sheets(1)"データシートのA1を基準とします
  Set rngList1 = Worksheets(1).Cells(1, "A")
  
  '"Sheets(2)"データシートのA1を基準とする
  Set rngList2 = Worksheets(2).Cells(1, "A")
  
  '結果を出力する"Sheets(3)"のA1を基準とする
  Set rngResult = Worksheets(3).Cells(1, "A")
  
  '"Sheets(1)"の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
  vntKeys1 = Array(0, 1, 2, 3)
  '"Sheets(2)"の比較列の列挙(基準セル位置からの列Offsetを列挙)
  'A列=0、C列=2、E列=4
  vntKeys2 = Array(0, 1, 2, 3)
  
  '"Sheets(1)"の比較データを保持する配列を確保
  ReDim vntList1(0 To UBound(vntKeys1))
  '"Sheets(2)"の比較データを保持する配列を確保
  ReDim vntList2(0 To UBound(vntKeys1))
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '"Sheets(1)"の基準に就いて
  If Not GetBasicData(rngList1, lngEnd1, clngColumns1, vntKeys1, vntList1) Then
    strProm = rngList1.Parent.Name & "にデータが有りません"
    GoTo Wayout
  Else
    vntItems1 = rngList1.Offset(, clngColumns1 - 1).Resize(lngEnd1 + 1).Value
  End If
  
  '"Sheets(2)"基準に就いて
  If Not GetBasicData(rngList2, lngEnd2, clngColumns2, vntKeys2, vntList2) Then
    strProm = rngList2.Parent.Name & "にデータが有りません"
    GoTo Wayout
  Else
    vntItems2 = rngList2.Offset(, clngColumns2 - 1).Resize(lngEnd2 + 1).Value
  End If
  
  '"Sheets(1)"のシートの比較位置
  lngRow1 = 1
  '"Sheets(2)"のシートの比較位置
  lngRow2 = 1
  '"Sheets(1)"のシート若しくは、"Sheets(2)"のシートが最終行に達するまで繰り返し
  Do Until lngRow1 > lngEnd1 Or lngRow2 > lngEnd2
    '各列のデータを比較
    lngMatch = IsSame(vntList1, lngRow1, vntList2, lngRow2)
    '比較結果に就いて
    Select Case lngMatch
      Case Is = 0 'Matchiした場合
        'E列の値が違った場合
        If vntItems1(lngRow1, 1) <> vntItems2(lngRow2, 1) Then
          '"Sheets(3)"に"Sheets(2)"の該当行をCopy
          rngList2.Offset(lngRow2 - 1).Resize(, clngColumns2).Copy _
                Destination:=rngResult.Offset(lngCount)
          '"Sheets(3)"の出力位置を更新
          lngCount = lngCount + 1
        End If
        '両データの比較位置の更新
        lngRow1 = lngRow1 + 1
        lngRow2 = lngRow2 + 1
      Case Is = 1 '"Sheets(2)"のシート固有値の場合
        '"Sheets(2)"のシートの比較位置を更新
        lngRow2 = lngRow2 + 1
      Case Is = -1 '"Sheets(1)"のシート固有値の場合
        '"Sheets(1)"のシートの比較位置を更新
        lngRow1 = lngRow1 + 1
    End Select
  Loop
    
  '"Sheets(1)"のシートの順位を復帰
  DataRestore rngList1, lngEnd1, clngColumns1
  
  '"Sheets(2)"のシートの順位を復帰
  DataRestore rngList2, lngEnd2, 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 + 1
    'データが無ければFunctionを抜ける(戻り値=False)
    If lngRows < 1 And .Value = "" 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(, lngColumns).EntireColumn.Insert
    '復帰用Keyの出力
    .Offset(, lngColumns).Resize(lngRows).Value = lngNumb
    'データをvntKeys1列で整列
    For i = UBound(vntKeys) To 0 Step -1
      DataSort .Resize(lngRows, lngColumns + 1), .Offset(, vntKeys(i))
    Next i
    '比較用配列にデータを取得
    For i = 0 To UBound(vntKeys)
      vntData(i) = .Offset(, 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 .Resize(lngRows, lngColumns + 1), .Offset(, 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 IsSame(vntData1 As Variant, lngPos1 As Long, _
            vntData2 As Variant, lngPos2 As Long) As Long

'  データの大小比較

  Dim i As Long
  Dim lngMax As Long
  
  '1行の最大比較回数を取得(実際は0から始まる為、回数としては+1と成る)
  lngMax = UBound(vntData1, 1)
  
  '1行のKeyを先頭から比較
  For i = 0 To lngMax
    'もし、Keyが不一致なら
    If vntData1(i)(lngPos1, 1) <> vntData2(i)(lngPos2, 1) Then
      'Forを抜ける
      Exit For
    End If
  Next i
  
  'もし、Keyが全て一致した場合(Forが全て回り終った場合、iはlngMax+1と成る)
  If i > lngMax Then
    '戻り値の値として、「等しい」を返す
    IsSame = 0
  Else
    'vntData1の値が、vntData2の値因り小さい場合
    If vntData1(i)(lngPos1, 1) < vntData2(i)(lngPos2, 1) Then
      '戻り値の値として、「小さい」を返す
      IsSame = -1
    Else
      '戻り値の値として、「大きい」を返す
      IsSame = 1
    End If
  End If
  
End Function
1 hits

【42228】処理時間の短縮 06/9/4(月) 16:26 質問
【42229】Re:処理時間の短縮 かみちゃん 06/9/4(月) 17:00 発言
【42287】Re:処理時間の短縮 06/9/5(火) 16:45 お礼
【42235】Re:処理時間の短縮 ハチ 06/9/4(月) 19:14 回答
【42261】Re:処理時間の短縮 06/9/5(火) 10:27 お礼
【42291】Re:処理時間の短縮 ハチ 06/9/5(火) 17:18 発言
【42307】Re:処理時間の短縮 06/9/6(水) 10:16 お礼
【42236】Re:処理時間の短縮 Hirofumi 06/9/4(月) 19:42 回答
【42238】Re:処理時間の短縮 飛ばない豚 06/9/4(月) 20:08 回答
【42256】Re:処理時間の短縮 飛ばない豚 06/9/5(火) 9:22 回答
【42259】Re:処理時間の短縮 Kein 06/9/5(火) 10:11 回答
【42308】Re:処理時間の短縮(解決) 06/9/6(水) 10:24 お礼

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