該当するデータを書式設定ごと転記したい

「元データ」シートというA〜AA列のデータがあります。
AA列の支店ごとに該当する人をそれぞれ抽出し、同じブック内に別シートとしてデータを転記したいです。

AA列で「東京」に該当する人であれば、たなかたろうさん、さとうたまこさんのA～Y列のデータを別シートとして転記したいです。

その際、8、9行目のやまださん、斉藤さんやI列、M列、Y列のような色付けしている行列の書式もそのまま転記したいです。

元データシート画像
https://gyazo.com/e7de8e043f071c8556816709282e3c08

データ転記後画像
https://gyazo.com/e953f5fcd0d9ceabf4c27e6f3c852793

以下、記載したモジュールは別の案件で使用したものなのですがこれを書式ごとコピーして今回のように修正したい場合
どこを修正したらよいかご教授願います。
↓
Sub 転記()
Dim データ範囲 As Range
Dim 条件範囲 As Range
Dim 列 As Long
Dim シート As Worksheet
Dim i As Long
Set データ範囲 = Range("A1").CurrentRegion
列 = 8
Set 条件範囲 = データ範囲.Cells(1).Offset(0, データ範囲.Columns.Count + 1)
データ範囲.Columns(列).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=条件範囲, Unique:=True
Set 条件範囲 = 条件範囲.CurrentRegion
For i = 2 To 条件範囲.Rows.Count
条件範囲.Cells(2, 1).Value = 条件範囲.Cells(i, 1).Value
Set シート = Worksheets.Add(after:=Worksheets(Worksheets.Count))
シート.Name = 条件範囲.Cells(2, 1).Value
データ範囲.Range("A1:H1").Copy シート.Range("A1")
データ範囲.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=条件範囲.Rows("1:2"), CopyToRange:=シート.Range("A1：H1")
シート.Range("A1").CurrentRegion.EntireColumn.AutoFit
Next i
条件範囲.Clear
End Sub

No.6 ベストアンサー 回答者： Qchan1962 回答日時： 2021/04/28 18:54

こんばんは、

やはりZ列は使用されていないのでしょうか？
非表示にされていたのと結果シートで数値があったので
使用されている事を前提にしました。
エラーは空白に囲まれた範囲の取得にAA列が入っていない為かと

Z5セルにアンダーバーなど何だかの値を入れ
（フォント色を背景と同じでOK）実行してみてください。

あと、最後の　.Range("A1").Select　これエラーになるかと
シート選択されていないので　前に　.Select　のみを追加してください
＃５のElseも忘れずに。。。

Z列の変更が出来ない場合は、書き直すか、実行時にVBAで暫定値を入力
終了時削除するなどのコードを追加する必要があると思います。

この回答へのお礼

ご返信ありがとうございます。

Z列は元々抽出したデータが入っています。
.Range("A1").Selectも修正してもう一度祝日明けに試してみます。

お礼日時：2021/04/28 21:06

No.5 回答者： Qchan1962 回答日時： 2021/04/24 16:53

本当に何度も申し訳ないです

＃４　1行抜けていました
シート.Name = key
シート.Cells.Clear
この間にElseを入れてください。
周辺を含めると
If シート Is Nothing Then
Set シート = Worksheets.Add(after:=Worksheets(Worksheets.Count))
シート.Name = key
Else
シート.Cells.Clear
End If
こんな感じです。

No.4 回答者： Qchan1962 回答日時： 2021/04/24 14:56

何度もすみません。

結合セルがあるのですね。
＃３ではうまくいかないので、少し変えました。
部分的な事ですが、全部を掲示します。

Sub Debug_sample()
Dim area_list As New Collection
Dim i As Long, key
Dim sh As Worksheet, シート As Worksheet
With ActiveSheet
For i = 6 To .Cells(Rows.Count, "AA").End(xlUp).Row
On Error Resume Next
If .Cells(i, "AA") <> "" Then
area_list.Add .Cells(i, "AA"), CStr(.Cells(i, "AA"))
On Error GoTo 0
End If
Next
For Each key In area_list
For Each sh In Worksheets
If sh.Name = key Then
Set シート = sh
Exit For
End If
Next
If シート Is Nothing Then
Set シート = Worksheets.Add(after:=Worksheets(Worksheets.Count))
シート.Name = key
シート.Cells.Clear
End If
If .AutoFilterMode = True Then .Range("A6").AutoFilter
.Rows("4:5").Copy シート.Rows("4:5")
.Range("A6").AutoFilter _
Field:="27", Criteria1:=key
.Range("A6:AA" & .Range("AA6").CurrentRegion.End(xlDown).Row).SpecialCells(xlCellTypeVisible).Copy _
シート.Range("A6")
シート.Range("B2") = key & " : " & .Range("B2")
Set シート = Nothing
Next
.Range("A6").AutoFilter
.Range("A1").Select
End With
End Sub

他にも色々やり方がありますが、一例です。

この回答へのお礼

ご返信が遅くなり申し訳ありません。

ご教授頂いたモジュールで検証させていただきましたところ、下記の部分でエラーで止まってしまいました。
※シート.Range("A6")のところで構文が正しくありませんとメッセージ表示されます。

.Range("A6:AA" & .Range("AA6").CurrentRegion.End(xlDown).Row).SpecialCells(xlCellTypeVisible).Copy _
シート.Range("A6")

申し訳ありませんが、なにが原因でしょうか？
恐れ入りますが、ご教授願います。

お礼日時：2021/04/28 18:27

No.3 回答者： Qchan1962 回答日時： 2021/04/24 14:09

こんにちは、

＃１です。AdvancedFilterで処理が難しいのですね。
出来ると思て行ったので、記録マクロで自力解決をと思ったのですが、、
Webに上げられた参考画像を拝見しました。
下記のコードで処理できますでしょうか？（代替え案です）

出力シートは、キーワード名のシートがあれば、上書きされ、なければ新規シートが作成されます。

Sub Debug_sample()
Dim area_list As New Collection
Dim i As Long, key
Dim sh As Worksheet, シート As Worksheet
With ActiveSheet
For i = 6 To .Cells(Rows.Count, "AA").End(xlUp).Row
On Error Resume Next
If .Cells(i, "AA") <> "" Then
area_list.Add .Cells(i, "AA"), CStr(.Cells(i, "AA"))
On Error GoTo 0
End If
Next
For Each key In area_list
For Each sh In Worksheets
If sh.Name = key Then
Set シート = sh
Exit For
End If
Next
If シート Is Nothing Then
Set シート = Worksheets.Add(after:=Worksheets(Worksheets.Count))
シート.Name = key
シート.Cells.Clear
End If
.Range("A4").AutoFilter _
Field:="27", Criteria1:=key
.Range("A4").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
シート.Range("A4")
シート.Range("B2") = key & " : " & .Range("B2")
Set シート = Nothing
Next
End With
End Sub

ActiveSheetは、該当シートオブジェクトに変更してください。
AdvancedFilterにこだわりがあるようであれば、この回答は、忘れてください。

この回答へのお礼

ご丁寧にご教授いただきましてありがとうございます。
週明け、ご提示頂いたモジュールを使用させていただきます。また、不明点あれば質問させてください。

お礼日時：2021/04/24 15:13

No.2 回答者： ママチャリ 回答日時： 2021/04/24 08:14

「色付けしている行列の書式もそのまま転記したい」とのことですが、AdvancedFilterって、文字の色や塗りつぶしの色も一緒に転記してくれるようなので、特に意識する必要は無く、このままでいけると思います。

問題は項目見出し行の作り方です。見た目を重視して2行の項目見出しにしているようですが、これではAdvancedFilterは正しく機能しません。
もし、見出し行を添付画像のように変更できるのであれば、少しの改修で対応可能ですが、変更できない（見た目を重視する必要がある）のであれば、AdvancedFilterでは不可能なので、全面的な書き直しが必要になります。
さぁ、どうしますか？

この回答へのお礼

ご教授いただきましてありがとうございます。

見出しはシステムからデータ抽出したものになりますので、仕様は変えられません。

ちなみに、支店別のシートを既に作成しておき
4.5行目の見出しも既に作成していた場合、データの6行目からデータを転記したいとなると修正が必要でしょうか？

お礼日時：2021/04/24 12:59

No.1 回答者： Qchan1962 回答日時： 2021/04/23 23:53

こんばんは、

＞別の案件で使用したものなのですがこれを書式ごとコピーして
＞今回のように修正したい場合、どこを修正したらよいかご教授願います。

各変数の参照先、値を変更する必要があるように思います。
＞Set 条件範囲 = 条件範囲.CurrentRegion
これは、除外できるかも
更にシート名設定に使用されている参照先
コピー範囲、ペースト先なども変更が必要ですね。

以下回答ではありませんが、
コードを書いてくれた方が1行1行解説して書き直してくれるのは、あまり期待できないと思います。

使用されているコードなので処理内容（流れ）をある程度理解しているのではないでしょうか？
であれば、自動記録マクロを使用して今回行いたい処理を行ってみてください。
記録されたものと、掲示のコードを見比べながら変数部分などを探れば、
作成できると思います。

記録マクロで
Range("A4").CurrentRegionを記録する場合は、
（表組みを考慮すると、多分A4セル）Excelの機能を活用して
A4セルを選択してCtrl＋Shift＋*キーを押せば下記の様に記録され
Range("A4").Select
Selection.CurrentRegion.Select
Selectと続くSelection.を省略すればA4セルを含む空白に囲まれた範囲が対象になります。
元コードの　Set データ範囲 = Range("A1").CurrentRegionを指します

記録マクロなどを使用して自身で先に進むか、
今回の事例に合わせた実行コードを書いてくれる方を待つかは、かのん2222様の自由ですが、丸投げ感あり有より、もう少し進んでみるのが良いと思いますよ

この回答へのお礼

こんにちわ。
アドバイスいただきましてありがとうございます。
いろいろと自身で検証してみます。

お礼日時：2021/04/24 12:52