| |
▼凪 さん：
力技を一つ。
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
もうちょっとスマートに書けそうな気がしますが、参考までに(^･ω･^)
|
|
飛ばない豚
- 06/9/4(月) 20:08 -
