Excel VBA質問箱 IV

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

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


42347 / 76732 ←次へ | 前へ→

【39456】Re:処理速度アップの方法は無いですか
回答  Hirofumi  - 06/6/24(土) 14:14 -

引用なし
パスワード
   '"対象マスター"のA列と"発注商品"のA列を比較して、同じ物が有ったら
'"発注商品"の其の行を削除すると言う事で善いのかな?

Option Explicit

Public Sub DataMatch()

'  検索条件に合ったものを行ごと削除

  '"対象マスター"のデータ列数(A列〜J列の10列)
  Const clngColumns1 As Long = 10
  '"対象マスター"の比較Key列位置(基準からのA列「Jコード」列Offset値)
  Const clngKeys1 As Long = 0
  '"発注商品"のデータ列数(A列〜C列の3列)
  Const clngColumns2 As Long = 3
  '"発注商品"の比較Key列位置(基準からのA列「Jコード」の列Offset値)
  Const clngKeys2 As Long = 0
  '"発注商品"の最終整列Key列(C列)
  Const clngSort As Long = 2
  
  Dim i As Long
  Dim rngList1 As Range
  Dim lngEnd1 As Long
  Dim vntData1 As Variant
  Dim lngRow1 As Long
  Dim rngList2 As Range
  Dim lngEnd2 As Long
  Dim vntData2 As Variant
  Dim lngRow2 As Long
  Dim lngDelete() As Long
  Dim lngCount As Long
  Dim strProm As String

  '"対象マスター"データのA1を基準とします(列見出しのセル位置)
  Set rngList1 = Worksheets("対象マスター").Cells(1, "C")
  
  '"発注商品"データのA1を基準とする(列見出しのセル位置)
  Set rngList2 = Worksheets("発注商品").Cells(1, "A")
  
  '画面更新を停止
'  Application.ScreenUpdating = False
  
  '"対象マスター"データの基準に就いて基礎データの取得
  If Not GetBasicData(rngList1, lngEnd1, clngColumns1, clngKeys1, vntData1) Then
    strProm = rngList1.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  '"発注商品"データの基準に就いて基礎データの取得
  If Not GetBasicData(rngList2, lngEnd2, clngColumns2, clngKeys2, vntData2) Then
    strProm = rngList2.Parent.Name & "にデータが有りません"
    GoTo Wayout
  End If
  
  '削除Flagの配列を確保
  ReDim lngDelete(1 To lngEnd2, 1 To 1)
  
  '"対象マスター"の比較位置
  lngRow1 = 1
  '"発注商品"の比較位置
  lngRow2 = 1
  '"対象マスター"若しくは、"発注商品"が最終行に達するまで繰り返し
  Do Until lngRow1 > lngEnd1 Or lngRow2 > lngEnd2
    '比較結果に就いて
    Select Case vntData1(lngRow1, 1)
      Case Is = vntData2(lngRow2, 1) 'Matchiした場合
        '削除Flagを立てる
        lngDelete(lngRow2, 1) = 1
        '削除数をカウント
        lngCount = lngCount + 1
        '両データの比較位置の更新
        lngRow1 = lngRow1 + 1
        lngRow2 = lngRow2 + 1
      Case Is > vntData2(lngRow2, 1) '"発注商品"固有値の場合
        '"発注商品"の比較位置を更新
        lngRow2 = lngRow2 + 1
      Case Is < vntData2(lngRow2, 1) '"対象マスター"固有値の場合
        '"対象マスター"の比較位置を更新
        lngRow1 = lngRow1 + 1
    End Select
  Loop

  '"対象マスター"データの復旧
  With rngList1
    '元データ順位を復帰
    .Offset(1).Resize(lngEnd1, clngColumns1 + 1).Sort _
        Key1:=.Offset(1, clngColumns1), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke

    '復帰用Key列を削除
    .Offset(, clngColumns1).EntireColumn.Delete
  End With
  
  With rngList2
    '削除Flagの配列を出力
    .Offset(1, clngColumns2 + 1) _
          .Resize(lngEnd2).Value = lngDelete
    '削除Flag列順のC列順で整列
    .Offset(1).Resize(lngEnd2, clngColumns2 + 2).Sort _
        Key1:=.Offset(1, clngColumns2 + 1), Order1:=xlAscending, _
        Key2:=.Offset(1, clngSort), Order2:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '削除データが有るなら
    If lngCount > 0 Then
      '行削除
      .Offset(lngEnd2 - lngCount + 1) _
            .Resize(lngCount).EntireRow.Delete
      strProm = lngCount & "件の削除が完了しました"
    Else
      strProm = "削除行が有りません"
    End If
    '復帰用Key列を削除
    .Offset(, clngColumns2).Resize(, 2).EntireColumn.Delete
  End With
  
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, _
                lngKeys As Long, _
                vntData As Variant) As Boolean

  Dim i As Long
  Dim lngNumb() As Long
  
  '基準に就いて
  With rngList
    '行数を取得
    lngRows = .Offset(65536 - .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
    'データをlngKeys列で整列
    .Offset(1).Resize(lngRows, lngColumns + 1).Sort _
        Key1:=.Offset(1, lngKeys), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    'データを配列に取得
    vntData = .Offset(1, lngKeys).Resize(lngRows + 1).Value
  End With
  
  GetBasicData = True

End Function

0 hits

【39450】処理速度アップの方法は無いですか 勉強中です 06/6/24(土) 10:34 質問
【39453】Re:処理速度アップの方法は無いですか てっちゃん 06/6/24(土) 13:42 回答
【39454】Re:処理速度アップの方法は無いですか 勉強中です 06/6/24(土) 13:58 お礼
【39455】Re:処理速度アップの方法は無いですか Kein 06/6/24(土) 14:10 回答
【39456】Re:処理速度アップの方法は無いですか Hirofumi 06/6/24(土) 14:14 回答
【39457】Re:処理速度アップの方法は無いですか Hirofumi 06/6/24(土) 14:20 回答
【39462】Re:処理速度アップの方法は無いですか 勉強中です 06/6/24(土) 15:28 お礼
【39473】Re:処理速度アップの方法は無いですか Hirofumi 06/6/24(土) 18:59 回答
【39475】Re:処理速度アップの方法は無いですか 勉強中です 06/6/24(土) 19:53 お礼

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