Excel VBA質問箱 IV

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

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


6925 / 13646 ツリー ←次へ | 前へ→

【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 お礼[未読]

【42228】処理時間の短縮
質問    - 06/9/4(月) 16:26 -

引用なし
パスワード
   今現在、sheets(1)の1行取得しsheets(2)の1行も取得
比較し「E列」が値が異なる場合のみ
sheets(3)にコピーする様にしたいのですが
今現在のコードだと30分以上かかってしまいあまりにも効率が悪い為
同じ条件で処理時間の短縮を図るにはどのようにしたらいいでしょうか?

※本試験では各シート約1500行あります。


sheets(1)
 A   B   C   D   E
1 A1  B1  C1  D1  E1
2 A1  B1  C1  D2  E2
3 A1  B1  C1  D3  E3
4 A1  B1  C1  D4  E4
5 A1  B1  C1  D5  E5

sheets(2)
 A   B   C   D   E
1 A1  B1  C1  D1  xx
2 A1  B1  C1  D2  E2
3 A1  B1  C1  D3  yy
4 A1  B1  C1  D4  E4
5 A1  B1  C1  D5  zz

sheets(3)
 A   B   C   D   E
1 A1  B1  C1  D1  xx
2 A1  B1  C1  D3  yy
3 A1  B1  C1  D5  zz

コード
s3x = 0
With Sheets(1)
For X = 1 To .UsedRange.Rows.Count
  s1prm(0) = .Cells(X, 1)
  s1prm(1) = .Cells(X, 2)
  s1prm(2) = .Cells(X, 3)
  s1prm(3) = .Cells(X, 4)
  s1prm(4) = .Cells(X, 5)
  
  With Sheets(2)
  For Y = 1 To .UsedRange.Rows.Count
    s2prm(0) = .Cells(Y, 1)
    s2prm(1) = .Cells(Y, 2)
    s2prm(2) = .Cells(Y, 3)
    s2prm(3) = .Cells(Y, 4)
    s2prm(4) = .Cells(Y, 5)
    If s1prm(0) <> s2prm(0) Then
    ElseIf s1prm(1) <> s2prm(1) Then
    ElseIf s1prm(2) <> s2prm(2) Then
    ElseIf s1prm(3) = s2prm(3) Then
      If s1prm(4) = s2prm(4) Then
        Exit For
      ElseIf s1prm(4) <> s2prm(4) Then
        Diff_V = True
        Exit For
      End If
    End If
  Next
  End With
      
  With Sheets(3)
  If Diff_V = True Then
    .Cells(s3x, 1) = s2prm(0)
    .Cells(s3x, 2) = s2prm(1)
    .Cells(s3x, 3) = s2prm(2)
    .Cells(s3x, 4) = s2prm(3)
    .Cells(s3x, 5) = s2prm(4)
    s3x = s3x + 1      
    Diff_V = False
  End If
  End With
Next
End With

よろしくお願いします。

【42229】Re:処理時間の短縮
発言  かみちゃん  - 06/9/4(月) 17:00 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>今現在、sheets(1)の1行取得しsheets(2)の1行も取得
>比較し「E列」が値が異なる場合のみ
>sheets(3)にコピーする様にしたいのですが
>今現在のコードだと30分以上かかってしまいあまりにも効率が悪い為
>同じ条件で処理時間の短縮を図るにはどのようにしたらいいでしょうか?

Sheet1およびSheet2が同じ行数であること、
A列〜D列の内容の確認は行なわないこと
である前提ですと、以下のコードでいかがでしょうか?
提示されたデータによる動作確認はしましたが、1500行の負荷試験はしていませ
んので、結果うまくいけば、どれくらい短縮になったか教えてください。

Sub Macro1()
 Dim vntData1 As Variant
 Dim vntData2 As Variant
 Dim lngMaxRow As Long
 Dim lngRow As Long
 Dim lngResultRow As Long
 
 vntData1 = Sheets("Sheet1").Range("A1").CurrentRegion.Value
 vntData2 = Sheets("Sheet2").Range("A1").CurrentRegion.Value
 lngMaxRow = UBound(vntData1, 1)
 For lngRow = 1 To lngMaxRow
  If vntData1(lngRow, 5) <> vntData2(lngRow, 5) Then
   lngResultRow = lngResultRow + 1
   Sheets("Sheet3").Cells(lngResultRow, 1).Resize(, 5).Value = _
    Array(vntData2(lngRow, 1), vntData2(lngRow, 2), vntData2(lngRow, 3), vntData2(lngRow, 4), vntData2(lngRow, 5))
  End If
 Next
 MsgBox "Fin!!"
End Sub

【42235】Re:処理時間の短縮
回答  ハチ  - 06/9/4(月) 19:14 -

引用なし
パスワード
   ▼凪 さん:
WorkSheetFunctionを2回使って抽出してみました。
IV列,IU列は空けておいてください。

Option Explicit
'各IV列,IU列を作業列に使う。
Sub Test()

Dim Ran1 As Range

Application.ScreenUpdating = False
With Worksheets(1)
  Set Ran1 = .Range(.Range("A1"), .Range("A65536").End(xlUp)).Offset(, 255)
End With
Ran1.Formula = "=CONCATENATE(A1,B1,C1,D1)"
Ran1.Value = Ran1.Value

On Error Resume Next
With Worksheets(2)
  With .Range(.Range("A1"), .Range("A65536").End(xlUp))
    '4つのセルで比較。一致するモノがなければ非表示
    .Offset(, 255).Formula = "=CONCATENATE(A1,B1,C1,D1)"
    .Offset(, 255).Value = .Offset(, 255).Value
    .Offset(, 254).Formula = "=IF(COUNTIF(Sheet1!" & Ran1.Address & ",IV1)=0,"""",1)"
    .Offset(, 254).Value = .Offset(, 254).Value
    .Offset(, 254).SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
    
    '可視セルを5つのセルで比較。一致していれば非表示
    Ran1.Formula = "=CONCATENATE(A1,B1,C1,D1,E1)"
    Ran1.Value = Ran1.Value
    .Offset(, 255).SpecialCells(xlCellTypeVisible).Formula = _
    "=CONCATENATE(A1,B1,C1,D1,E1)"
    .Offset(, 255).Value = .Offset(, 255).Value
    .Offset(, 254).SpecialCells(xlCellTypeVisible).Formula = _
    "=IF(COUNTIF(Sheet1!" & Ran1.Address & ",IV1)=0,1,"""")"
    .Offset(, 254).Value = .Offset(, 254).Value
    .Offset(, 254).SpecialCells(xlCellTypeBlanks).EntireRow.EntireRow.Hidden = True
    '残って表示されているセルをSheet3にコピー
    .Resize(, 5).SpecialCells(xlCellTypeVisible).Copy Worksheets(3).Range("A1")
    
    '後処理
    .EntireRow.Hidden = False
    .Offset(, 255).Delete xlShiftToLeft
    .Offset(, 254).Delete xlShiftToLeft
  End With
  Ran1.Delete xlShiftToLeft
  Set Ran1 = Nothing
End With
On Error GoTo 0
Application.ScreenUpdating = True

End Sub

【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

【42238】Re:処理時間の短縮
回答  飛ばない豚  - 06/9/4(月) 20:08 -

引用なし
パスワード
   ▼凪 さん:
力技を一つ。

Sheet1,Sheet2のデータをSheet3に貼り付けて
ワークシート関数で判定してみました。


Private Sub sub_sample()
  Dim myRow As Long
  Dim myLooP As Long
  
  'Sheet3をクリア
  Sheets("Sheet3").Cells.ClearContents
  
  'Sheet1のコピー
  Sheets("Sheet1").Select
  myRow = Range("A1").CurrentRegion.Rows.Count
  Range("A1").CurrentRegion.Select
  Selection.Copy
  Range("A1").Select
  Sheets("Sheet3").Select
  Range("A1").Select
  Selection.PasteSpecial Paste:=xlPasteValues
  Application.CutCopyMode = False
  Range(Cells(1, 6), Cells(myRow, 6)).Value = "Sheet1"
  
  Cells(myRow + 1, 1).Select
  
  'Sheet2のコピー
  Sheets("Sheet2").Select
  myRow = Range("A1").CurrentRegion.Rows.Count
  Range("A1").CurrentRegion.Select
  Selection.Copy
  Range("A1").Select
  Sheets("Sheet3").Select
  Cells(Cells.Rows.Count, 1).End(xlUp).Offset(1, 0).Select
  Selection.PasteSpecial Paste:=xlPasteValues
  Application.CutCopyMode = False
  myRow = myRow + ActiveCell.Row - 1
  Range(Cells(ActiveCell.Row, 6), Cells(myRow, 6)).Value = "Sheet2"
  
  
  '並べ替え
  For myLooP = 6 To 1 Step -1
    Range("A1").CurrentRegion.Sort Key1:=Cells(1, myLooP), _
                    Order1:=xlDescending, _
                    Header:=xlGuess
  Next myLooP
  
  '対象を見つける
  Range(Cells(1, 7), Cells(myRow, 7)).FormulaR1C1 = _
  "=IF(AND(RC[-6]=R[1]C[-6],RC[-5]=R[1]C[-5],RC[-4]=R[1]C[-4],RC[-3]=R[1]C[-3],RC[-2]<>R[1]C[-2],RC[-1]=""Sheet2""),-1,0)"
  
  '式を消す
  Range(Cells(1, 7), Cells(myRow, 7)).Select
  Selection.Copy
  Selection.PasteSpecial Paste:=xlPasteValues
  Application.CutCopyMode = False
  
  '作業エリアの削除
  myRow = Application.WorksheetFunction.Sum(Range(Cells(1, 7), Cells(myRow, 7))) * -1
  Debug.Print myRow
  Range("A1").CurrentRegion.Sort Key1:=Range("G1"), _
                  Order1:=xlAscending, _
                  Header:=xlGuess
  Range(Cells(myRow + 1, 1), Cells(Range("A1").CurrentRegion.Rows.Count, 7)).ClearContents
  Range(Cells(1, 6), Cells(myRow, 7)).ClearContents
  
  Range("A1").Select
  
  MsgBox "終了"
End Sub


もうちょっとスマートに書けそうな気がしますが、参考までに(^・ω・^)

【42256】Re:処理時間の短縮
回答  飛ばない豚  - 06/9/5(火) 9:22 -

引用なし
パスワード
   ▼凪 さん:
すみません。一晩寝て見直してみたら、間違いありました。m(_~_)m

訂正箇所を入れるとゴチャゴチャしそうだったので、
再度全てのコードを載せます。

Private Sub sub_sample()
  Dim myRow As Long
  Dim myLooP As Long
  
  'Sheet3をクリア
  Sheets("Sheet3").Cells.ClearContents
  
  'Sheet1のコピー
  Sheets("Sheet1").Select
  myRow = Range("A1").CurrentRegion.Rows.Count
  Range("A1").CurrentRegion.Select
  Selection.Copy
  Range("A1").Select
  Sheets("Sheet3").Select
  Range("A1").Select
  Selection.PasteSpecial Paste:=xlPasteValues
  Application.CutCopyMode = False
  Range(Cells(1, 6), Cells(myRow, 6)).Value = "Sheet1"
  
  Cells(myRow + 1, 1).Select
  
  'Sheet2のコピー
  Sheets("Sheet2").Select
  myRow = Range("A1").CurrentRegion.Rows.Count
  Range("A1").CurrentRegion.Select
  Selection.Copy
  Range("A1").Select
  Sheets("Sheet3").Select
  Selection.PasteSpecial Paste:=xlPasteValues
  Application.CutCopyMode = False
  myRow = myRow + ActiveCell.Row - 1
  Range(Cells(ActiveCell.Row, 6), Cells(myRow, 6)).Value = "Sheet2"
  
  '並べ替え--訂正
  Range("A1").CurrentRegion.Sort Key1:=Range("F1"), _
                  Order1:=xlDescending, _
                  Header:=xlGuess
  For myLooP = 4 To 1 Step -1
    Range("A1").CurrentRegion.Sort Key1:=Cells(1, myLooP), _
                    Order1:=xlAscending, _
                    Header:=xlGuess
  Next myLooP
  
  '対象を見つける--訂正
  Range(Cells(1, 7), Cells(myRow, 7)).FormulaR1C1 = _
  "=IF(AND(RC[-6]=R[1]C[-6],RC[-5]=R[1]C[-5],RC[-4]=R[1]C[-4],RC[-3]=R[1]C[-3],RC[-2]<>R[1]C[-2],RC[-1]=""Sheet2"",R[1]C[-1]=""Sheet1""),-1,0)"
  
  '式を消す
  Range(Cells(1, 7), Cells(myRow, 7)).Select
  Selection.Copy
  Selection.PasteSpecial Paste:=xlPasteValues
  Application.CutCopyMode = False
  
  '作業エリアの削除
  myRow = Application.WorksheetFunction.Sum(Range(Cells(1, 7), Cells(myRow, 7))) * -1
  Range("A1").CurrentRegion.Sort Key1:=Range("G1"), _
                  Order1:=xlAscending, _
                  Header:=xlGuess
  Range(Cells(myRow + 1, 1), Cells(Range("A1").CurrentRegion.Rows.Count, 7)).ClearContents
  Range(Cells(1, 6), Cells(myRow + 1, 7)).ClearContents
  
  Range("A1").Select
  
  MsgBox "終了"
End Sub


並べ替え、ワークシート関数、のところを訂正してます。
また、対象が0件だった場合の対策と、抽出後の並び順を修正してます。

【42259】Re:処理時間の短縮
回答  Kein  - 06/9/5(火) 10:11 -

引用なし
パスワード
   仮に Sheet2 の E列 を基準とするなら・・

Sub MyData_Copy()
  Dim MyR As Range

  On Error Resume Next
  With Worksheets("Sheet2")
   With .Range("E1", .Range("E65536").End(xlUp)).Offset(, 251)
     .Formula = "=IF(Sheet1!$E1<>$E1,1,"""")"
     Set MyR = .SpecialCells(3, 1)
   End With
   On Error GoTo 0
   If Err.Number <> 0 Then
     MsgBox "Sheet1のE列と違うデータはありません", 48
     .Range("$IV:$IV").ClearContents: Exit Sub
   End If
   Worksheets("Sheet3").Cells.ClearContents
   Intersect(MyR.EntireRow, .Range("$A:$IV")) _
   .Copy Worksheets("Sheet3").Range("A1")
   .Range("$IV:$IV").ClearContents
  End With
  Set MyR = Nothing
End Sub

【42261】Re:処理時間の短縮
お礼    - 06/9/5(火) 10:27 -

引用なし
パスワード
   ハチさん
回答ありがとうございます。
早速使ってみましたところ驚く速さで処理ができました。

ただソースが高等すぎて自分のレベルでは理解できなく一行ずつ
どの様な処理を行っているか解説をお願いできないでしょうか?
自分の持っている本や資料では載っていなかったので

よろしくお願いします。

【42287】Re:処理時間の短縮
お礼    - 06/9/5(火) 16:45 -

引用なし
パスワード
   はじめまして、かみちゃんさん。
かみちゃんさんのソースを元に加工して検証したところ
約1分を切り効率よく検出できました。

各々のシート行数が異なる場合でも処理時間は同じのようです。
ありがとうございました。
>
>Sheet1およびSheet2が同じ行数であること、
>A列〜D列の内容の確認は行なわないこと
>である前提ですと、以下のコードでいかがでしょうか?
>提示されたデータによる動作確認はしましたが、1500行の負荷試験はしていませ
>んので、結果うまくいけば、どれくらい短縮になったか教えてください。
>

【42291】Re:処理時間の短縮
発言  ハチ  - 06/9/5(火) 17:18 -

引用なし
パスワード
   ▼凪 さん:
>ただソースが高等すぎて自分のレベルでは理解できなく一行ずつ
>どの様な処理を行っているか解説をお願いできないでしょうか?

一行づつはさすがに大変なので概略だけ。
Application.ScreenUpdating = False をコメントアウトして
ステップ実行でどういう動作なのか確認してみてください。
Sheet1,Sheet2の右端のIU列、IV列あたりで変化があります。

1、
Sheet1,2のIV列のA,B,C,D列を結合した文字列を作る。

2、
Sheet2からCountIfで同じものがあるか確認。あればIFでフラグを立てる

3、
フラグがないSheet2を非表示に

4、
残っている行でA,B,C,D,EでCountIfであるか確認
あればフラグを立てて非表示に

5、
残っているのが対象の行なのでコピー

6、
後処理

【42307】Re:処理時間の短縮
お礼    - 06/9/6(水) 10:16 -

引用なし
パスワード
   ハチさん
解説のほうありがとうございました。

これで何とかなりそうです。

【42308】Re:処理時間の短縮(解決)
お礼    - 06/9/6(水) 10:24 -

引用なし
パスワード
   今回の処理時間の短縮
皆様の助言のおかげで無事解決することが出来ました。

本当にありがとうございました。

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