Excel VBA質問箱 IV

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

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


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

1520 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

▼

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

【73871】Re:コード整理 UO3 13/2/26(火) 20:30

【73876】Re:コード整理 UO3 13/2/27(水) 9:23


	【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


	【73871】Re:コード整理

UO3 - 13/2/26(火) 20:30 -


	引用なし

	パスワード

▼ハクエンさん：

こんばんは

振り分け後、元シートに対してしておられることの意味がいまいち把握できないので
（なんとなくわかるのですが）そこは割愛しています。
必要なら追加してください。

また、抽出がないときの手当はさぼっています。

Sub Sample()
　　Dim myKey As String
　　Dim mySht As String
　　Dim x As Long
　　Dim keyV As Variant
　　Dim shtV As Variant
　　
　　Application.ScreenUpdating = False
　　
　　keyV = Split("1.チームA 2.チームB 3.チームC 4.チームD 5.チームE 6.チームF 7.チームG 8.チームH")
　　shtV = Split("A B C D E F G H")
　　
　　
　　With Sheets("原紙")
　　
　　　　.AutoFilterMode = False
　　　　.Range("A1").AutoFilter
　　　　
　　　　For x = 1 To 8
　　　　　　myKey = keyV(x - 1)
　　　　　　mySht = shtV(x - 1)
　　　　　　
　　　　　　.AutoFilter.Range.AutoFilter Field:=4, Criteria1:=myKey
　　　　　　Sheets(mySht).UsedRange.Clear
　　　　　　.AutoFilter.Range.Copy Sheets(mySht).Range("A1")
　　　　　　With Sheets(mySht).UsedRange
　　　　　　　　.RowHeight = 22.5
　　　　　　　　.Resize(.Rows.Count - 1).Offset(1).Replace What:="" & Chr(10) & "", Replacement:="　", _
　　　　　　　　　　LookAt:=xlPart
　　　　　　End With
　　　　Next
　　　　
　　　　.AutoFilterMode = False
　　　　
　　End With
　　
　　Application.ScreenUpdating = True
　　MsgBox "振り分け完了"
　　
End Sub


	【73876】Re:コード整理

UO3 - 13/2/27(水) 9:23 -


	引用なし

	パスワード

▼ハクエンさん：

なんとなく、原紙シートにしておられるのは以下のことかなと。
（抽出済みの行を削除したいのですよね？）
抽出結果がなかった場合の対処も付け加えました。

Sub Sample2()
　　Dim myKey As String
　　Dim mySht As String
　　Dim x As Long
　　Dim keyV As Variant
　　Dim shtV As Variant
　　
　　Application.ScreenUpdating = False
　
　　keyV = Split("1.チームA 2.チームB 3.チームC 4.チームD 5.チームE 6.チームF 7.チームG 8.チームH")
　　shtV = Split("A B C D E F G H")
　
　　With Sheets("原紙")
　　　　'シートにオートフィルター設定
　　　　.AutoFilterMode = False
　　　　.Range("A1").AutoFilter
　　
　　　　For x = 1 To 8
　　　　　　myKey = keyV(x - 1)
　　　　　　mySht = shtV(x - 1)
　　　
　　　　　　.AutoFilter.Range.AutoFilter Field:=4, Criteria1:=myKey
　　　　　　If .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
　　　　　　　　Sheets(mySht).UsedRange.Clear
　　　　　　　　.AutoFilter.Range.Copy Sheets(mySht).Range("A1")
　　　　　　　　With Sheets(mySht).UsedRange
　　　　　　　　　　.RowHeight = 22.5
　　　　　　　　　　.Resize(.Rows.Count - 1).Offset(1).Replace What:="" & Chr(10) & "", Replacement:="　", _
　　　　　　　　　　　　LookAt:=xlPart
　　　　　　　　End With
　　　　　　　　'抽出済み行の削除
　　　　　　　　With .AutoFilter.Range
　　　　　　　　　　.Resize(.Rows.Count - 1).Offset(1).EntireRow.Delete
　　　　　　　　End With
　　　　　　End If
　　　　Next
　　
　　　　.AutoFilterMode = False
　　
　　End With
　
　　Application.ScreenUpdating = True
　　MsgBox "振り分け完了"
　
End Sub


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

1520 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free