Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

39586 / 76732

←次へ　｜　前へ→


	【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 並べ替え、ワークシート関数、のところを訂正してます。また、対象が０件だった場合の対策と、抽出後の並び順を修正してます。