[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『【VBA】可変条件でシートを分かる方法』（ペコパ）
VBAに関して質問失礼いたします。
社内システムでの抽出データに、担当者名が記載されています。
マクロにて担当者名毎にシートを分けたいと思っていますが、
難点なのが、担当者名が毎回変わります。
（ある月のデータは、担当者名:A.B.Cですが、
翌月は担当者名:D.E.Fになります。）
この様な場合、VBAでシート分けは可能でしょうか。
可能であれば、やり方を教えてください。
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
(1)担当者欄を見る (2)担当者A.B.C だったらシート１に貼付 担当者D.E.F だったらシート２に貼付 (3)行数？分繰り返す
でできませんか＞
（もこな２ ） 2020/03/09(月) 18:54
以下のようなレイアウトのエクセル表があります。
担当者名ごとにシートを分けたいと思ってますが、
今月は担当者がA,B,C、来月はD,E,Fと毎月担当者が変わります。
名前が未知の新規担当者も入ってくる可能性があります。
この場合、該当月の担当者名を取得し、
VBAで担当者名毎にシートを分けることは可能でしょうか。
構文も教えていただけると助かります。
以下「Macro1」は、マクロ記録で下表をシート分けした構文です。
（構文は可変にはなっていません）
この構文を一部つかえるのであれば、その部分を変更したらいいかなど、
ご教授いただけると助かります。
担当者名 商品コード 品名 売上
A 0070062 ガーベラ 11,111
B 0964342 バラ 33,333
B 0686019 チューリップ 555
C 0070062 ミモザ 6,666
C 0070062 カーネーション 4,444
C 0367325 アネモネ 5,555
Sub Macro1()
'
' Macro1 Macro
'
'
Range("A1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$D$7").AutoFilter Field:=1, Criteria1:="A"
ActiveSheet.Range("$A$1:$D$7").AutoFilter Field:=1
Range("A2").Select
ActiveSheet.Range("$A$1:$D$7").AutoFilter Field:=1, Criteria1:="A"
Cells.Select
Selection.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
Sheets("Sheet2").Select
Cells.Select
Sheets("Sheet2").Name = "A"
Sheets("Sheet1").Select
ActiveSheet.Range("$A$1:$D$7").AutoFilter Field:=1, Criteria1:="B"
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Sheets.Add After:=ActiveSheet
Sheets("Sheet3").Select
Sheets("Sheet3").Name = "B"
ActiveSheet.Paste
Range("E10").Select
Sheets("Sheet1").Select
ActiveSheet.Range("$A$1:$D$7").AutoFilter Field:=1, Criteria1:="C"
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Sheets.Add After:=ActiveSheet
Cells.Select
ActiveSheet.Paste
Sheets("Sheet4").Select
Sheets("Sheet4").Name = "c"
Sheets("Sheet1").Select
Range("F7").Select
ActiveSheet.Range("$A$1:$D$7").AutoFilter Field:=1
Range("A1").Select
End Sub
よろしくお願いいたします。
（ペコパ） 2020/03/09(月) 20:51
参考に
Sub Test()
Dim myDic As Object, d As Variant
Dim LastCell As Range, c As Range
Set myDic = CreateObject("Scripting.Dictionary")
With ActiveSheet
Set LastCell = .Cells(Rows.Count, "D").End(xlUp)
For Each c In .Range("A2", .Cells(Rows.Count, "A").End(xlUp))
myDic(c.Value) = Empty
Next
For Each d In myDic.keys
'シートの有無確認
If CheckSheet(d) = False Then
'無ければ追加
Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = d
End If
.Range("A1").AutoFilter Field:=1, Criteria1:=d
.Range("A2", LastCell).Copy Worksheets(d).Cells(Rows.Count, "A").End(xlUp).Offset(1)
Next
.AutoFilterMode = False
.Activate
End With
End Sub
Function CheckSheet(strSN As Variant) As Boolean
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name = strSN Then
CheckSheet = True
Exit For
End If
Next
End Function
（ピンク） 2020/03/09(月) 22:11
_____A___________B__________C______________D_________ 1 担当者名 商品コード 品名 売上 2 A 0070062 ガーベラ 11,111 3 B 0964342 バラ 33,333 4 B 0686019 チューリップ 555 5 C 0070062 ミモザ 6,666 6 C 0070062 カーネーション 4,444 7 C 0367325 アネモネ 5,555
ポイントは、
(1) なんとかして、担当者名の重複しないリストを作成する (2) 担当者名のシートが無ければ作成する (3) データ元シートで、オートフィルタを使って担当者名で抽出する (4) 抽出されたものをコピーして、担当者名のシートに貼付する (5) (2)～(4)を繰り返す。
という処理をどうやって組み立てるかだとおもいます。
このうち、(1),(3),(4)については、（アプローチによっては）マクロの記録でヒントとなるコードが得られます。
また、
(1)については
http://officetanaka.net/excel/vba/tips/tips80.htm
(2)については
http://officetanaka.net/excel/vba/tips/tips10.htm
https://mmm-program.com/vba-sheet-exist/
(3)については
http://officetanaka.net/excel/vba/tips/tips155.htm
などが参考になると思いますので、興味があればチャレンジしたり読んでみてはどうでしょうか。
長くなりましたが、最後に研究用のコードを提供します。
こちらも、興味があれば【ステップ実行】して、何をやっているのか研究してみてください、
※ステップ実行ってなんだ？という場合はこちらをご覧ください。
https://www.239-programing.com/excel-vba/basic/basic023.html
http://marupeke296.com/DBG_No1_Step.html
※ブレークポイントってなんだ？という場合はこちらをご覧ください。
https://www.tipsfound.com/vba/01010
https://www.239-programing.com/excel-vba/basic/basic022.html
Sub 研究用02()
Dim 作業用SH As Worksheet
Dim データSH As Worksheet
Dim 出力用SH As Worksheet
Dim i As Long, 最終行 As Long
Stop '←ブレークポイントの代わり
'▼データのあるシートを変数にセット
Set データSH = ActiveSheet
'▼作業用シートを作成して変数にセット
Set 作業用SH = Worksheets.Add(before:=Worksheets(1))
'▼作業用シートに担当者名の重複しないリストを作成
データSH.Range("A:A").Copy 作業用SH.Range("A1")
作業用SH.Range("A1").RemoveDuplicates Columns:=1, Header:=xlYes
'▼作業用シートの2行目から最終行まで順番にループ処理
最終行 = 作業用SH.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To 最終行
'▼出力用のシートを準備
Set 出力用SH = Nothing
On Error Resume Next
Set 出力用SH = Worksheets(作業用SH.Cells(i, "A").Value)
On Error GoTo 0
If 出力用SH Is Nothing Then
Set 出力用SH = Worksheets.Add(after:=Worksheets(Worksheets.Count))
出力用SH.Name = 作業用SH.Cells(i, "A").Value
End If
'▼データのあるシートでオートフィルタを実行して抽出
データSH.Range("A1").AutoFilter Field:=1, Criteria1:=作業用SH.Cells(i, "A").Value
'▼抽出したものをコピペ
データSH.AutoFilter.Range.Copy 出力用SH.Range("A1")
Next i
'▼後処理
Application.DisplayAlerts = False
作業用SH.Delete
データSH.AutoFilterMode = False
Application.DisplayAlerts = True
End Sub
（もこな２） 2020/03/10(火) 08:42
1点質問なのですが、現コードではA列の項目別にシート分けして頂いておりますが、
例えばA→G列に変更になった場合はシート分けは可能なのでしょうか。
TRYしてみたのですが、一応シート分けはできたのですが、
ファイル内のタイトル行以下の必要情報が反映しませんでした。
A列（左端列）にないと、うまいこと分けるのは厳しい等、
ルールはありますでしょうか。
何度も聞いて申し訳ありませんが、ご教授いただけましたら幸いです。
（なみ） 2020/03/10(火) 23:06
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.