Excel VBA質問箱 IV

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

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


39604 / 76732 ←次へ | 前へ→

【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


もうちょっとスマートに書けそうな気がしますが、参考までに(^・ω・^)
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 お礼

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