Excel VBA質問箱 IV

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

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


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

8438 / 76732

←次へ　｜　前へ→


	【73868】コード整理

ハクエン - 13/2/26(火) 16:23 -


	引用なし

	パスワード

以前お世話になりました、ハクエンと言います、その節はありがとうございました。
今回はコード整理のご相談をさせてください。

"原紙"sheetに入っているデータをにフィルターを掛けて
対象のsheetに切り取り/貼り付けをするマクロを作成しています。
複数種類のデータごとに処理する為、計8回処理を行います。
それとセル幅調整や余分なスペース/改行削除等、細かい部分も入っています。

取りあえずは「マクロの記録」を使用し、関数等は全く使っていませんが、
一応やりたい処理は出来ています。
しかし、コードが長く解り辛いので整理しろと依頼されまして、
どうしたら簡略化出来るのか解らず困っています。どうかご教授願います。

振り分け先

フィルタ名　→　　sheet名
1.チームA　　　　　A
2.チームB　　　　　B
　↓　連番&記号　 ↓
8.チームH　　　　　H

※処理が一緒の文面が8つあるだけです。
↓

Sub 振り分け_Click()
　　Sheets("原紙").Select
　　Rows("1:1").Select
　　Selection.AutoFilter
　　ActiveSheet.Range("$A$1:$E$161").AutoFilter Field:=4, Criteria1:= _
　　　　"1.チームA"
　　Rows("1:500").Select
　　Selection.Copy
　　Sheets("A").Select
　　Cells.Select
　　ActiveSheet.Paste
　　Selection.RowHeight = 22.5
　　　　　　　　Range("A2:E100").Select
　　Cells.Replace What:="" & Chr(10) & "", Replacement:="　", LookAt:=xlPart, SearchOrder _
　　　　:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
　　Sheets("原紙").Select
　　Rows("1:1000").Select
　　Application.CutCopyMode = False
　　Selection.Delete Shift:=xlUp
　　　　Rows("1:1").Select
　　Application.CutCopyMode = False
　　Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
　　

　　Sheets("原紙").Select
　　Rows("1:1").Select
　　Selection.AutoFilter
　　ActiveSheet.Range("$A$1:$E$161").AutoFilter Field:=4, Criteria1:= _
　　　　"2.チームB"
　　Rows("1:500").Select
　　Selection.Copy
　　Sheets("B").Select
　　Cells.Select
　　ActiveSheet.Paste
　　　　Selection.RowHeight = 22.5
　　　　　　Range("A2:E100").Select
　　Cells.Replace What:="" & Chr(10) & "", Replacement:="　", LookAt:=xlPart, SearchOrder _
　　　　:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
　　Sheets("原紙").Select
　　Rows("1:1000").Select
　　Application.CutCopyMode = False
　　Selection.Delete Shift:=xlUp
　　　　Rows("1:1").Select
　　Application.CutCopyMode = False
　　Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

　　Sheets("原紙").Select
　　Rows("1:1").Select
　　Selection.AutoFilter
　　ActiveSheet.Range("$A$1:$E$161").AutoFilter Field:=4, Criteria1:= _
　　　　"3.チームC"
　　Rows("1:500").Select
　　Selection.Copy
　　Sheets("C").Select
　　Cells.Select
　　ActiveSheet.Paste
　　Selection.RowHeight = 22.5
　　　　　　Range("A2:E100").Select
　　Cells.Replace What:="" & Chr(10) & "", Replacement:="　", LookAt:=xlPart, SearchOrder _
　　　　:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
　　Sheets("原紙").Select
　　Rows("1:1000").Select
　　Application.CutCopyMode = False
　　Selection.Delete Shift:=xlUp
　　　　Rows("1:1").Select
　　Application.CutCopyMode = False
　　Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

　　Sheets("原紙").Select
　　Rows("1:1").Select
　　Selection.AutoFilter
　　ActiveSheet.Range("$A$1:$E$161").AutoFilter Field:=4, Criteria1:= _
　　　　"4.チームD"
　　Rows("1:500").Select
　　Selection.Copy
　　Sheets("D").Select
　　Cells.Select
　　ActiveSheet.Paste
　　Selection.RowHeight = 22.5
　　　　　　Range("A2:E100").Select
　　Cells.Replace What:="" & Chr(10) & "", Replacement:="　", LookAt:=xlPart, SearchOrder _
　　　　:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
　　Sheets("原紙").Select
　　Rows("1:1000").Select
　　Application.CutCopyMode = False
　　Selection.Delete Shift:=xlUp
　　　　Rows("1:1").Select
　　Application.CutCopyMode = False
　　Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

　　Sheets("原紙").Select
　　Rows("1:1").Select
　　Selection.AutoFilter
　　ActiveSheet.Range("$A$1:$E$161").AutoFilter Field:=4, Criteria1:= _
　　　　"5.チームE"
　　Rows("1:500").Select
　　Selection.Copy
　　Sheets("E").Select
　　Cells.Select
　　ActiveSheet.Paste
　　Selection.RowHeight = 22.5
　　　　　　Range("A2:E100").Select
　　Cells.Replace What:="" & Chr(10) & "", Replacement:="　", LookAt:=xlPart, SearchOrder _
　　　　:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
　　Sheets("原紙").Select
　　Rows("1:1000").Select
　　Application.CutCopyMode = False
　　Selection.Delete Shift:=xlUp
　　　　Rows("1:1").Select
　　Application.CutCopyMode = False
　　Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

　　Sheets("原紙").Select
　　Rows("1:1").Select
　　ActiveSheet.Range("$A$1:$E$161").AutoFilter Field:=4, Criteria1:= _
　　　　"6.チームF"
　　Rows("1:500").Select
　　Selection.Copy
　　Sheets("F").Select
　　Cells.Select
　　ActiveSheet.Paste
　　Selection.RowHeight = 22.5　
　　Range("A2:E100").Select
　　Cells.Replace What:="" & Chr(10) & "", Replacement:="　", LookAt:=xlPart, SearchOrder _
　　　　:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False　
　　Sheets("原紙").Select
　　Rows("1:1000").Select
　　Application.CutCopyMode = False
　　Selection.Delete Shift:=xlUp
　　　　Rows("1:1").Select
　　Application.CutCopyMode = False
　　Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

　　Sheets("原紙").Select
　　Rows("1:1").Select
　　Selection.AutoFilter
　　ActiveSheet.Range("$A$1:$E$161").AutoFilter Field:=4, Criteria1:= _
　　　　"7.チームG"
　　Rows("1:500").Select
　　Selection.Copy
　　Sheets("G").Select
　　Cells.Select
　　ActiveSheet.Paste
　　Selection.RowHeight = 22.5
　　Range("A2:E100").Select
　　Cells.Replace What:="" & Chr(10) & "", Replacement:="　", LookAt:=xlPart, SearchOrder _
　　　　:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False　
　　　 Sheets("原紙").Select
　　Rows("1:1000").Select
　　Application.CutCopyMode = False
　　Selection.Delete Shift:=xlUp
　　　　Rows("1:1").Select
　　Application.CutCopyMode = False
　　Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
　　

　　Sheets("原紙").Select
　　Rows("1:1").Select
　　Selection.AutoFilter
　　ActiveSheet.Range("$A$1:$E$161").AutoFilter Field:=4, Criteria1:= _
　　　　"8.チームH"
　　Rows("1:500").Select
　　Selection.Copy
　　Sheets("H").Select
　　Cells.Select
　　ActiveSheet.Paste
　　Selection.RowHeight = 22.5
　　　　Range("A2:E100").Select
　　Cells.Replace What:="" & Chr(10) & "", Replacement:="　", LookAt:=xlPart, SearchOrder _
　　　　:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
　　Sheets("原紙").Select
　　Rows("1:1000").Select
　　Application.CutCopyMode = False
　　Selection.Delete Shift:=xlUp
　　　　Rows("1:1").Select
　　Application.CutCopyMode = False
　　Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove　
　　Sheets("コマンド").Select

MsgBox "処理終了"
　　
End Sub

302 hits

▼

【73868】コード整理 ハクエン 13/2/26(火) 16:23

≪