EXCEL VBA マクロ 別シート コピペ 特定の値

Question

前提・実現したいこと

VBA初心者です。
今回、【計算】というシートを基に別シートへ値をコピペするというVBAを作成したいです。
【計算用】のC列[利用場所]もしくはD列[会場]を絞り、その絞った単語のシートにコピペします。

例えば、C列［利用場所］の「新宿」でC列を絞り、その絞った名前のシート
(この場合は【新宿】というシート)にその決まった各項目ごとを各場所へコピペしたいのです。
（コピー先のシートは合間にチェックという項目が入っていたり、利用スポットの項目が
なくなっていたりと、絞った後の行をそのまま全コピーできません、、）
逆にD列［会場］で「東京」を絞るとまた少しコピー先の項目が少し変わるのでその項目通りに入れていきたいです。
この【計算用】シートの内容は各都市各県庁所在地5件以上入ることもあり、
もし5件以上であればコピー先のシートの枠もその分増えるようにできるのであればそうしたいです。
また、フォントはMeiryo UIでサイズ11で上下左右中央揃えになるとうれしいです。

どうかどうか宜しくお願いいたします。

試したこと

まず途中まで記載して下記のように実行してみたり、
オートフィルターを使用して別シートにコピーする方法など試しましたが
思うようにコピー場所がずれてしまって綺麗に当てはまらず、困惑しています、、

Sub Macro1()

Dim Sht1 As Worksheet
Dim Sht2 As Worksheet
Dim LastRow As Long
Dim i As Long
Dim J As Long
Dim SearchWord As String

Set Sht1 = Sheets("計算")
Set Sht2 = Sheets("新宿")

SearchWord = "新宿"
Sht1.Select
J = 2
LastRow = Sht1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
    If InStr1(Cells(i, 1), SearchWord) > 0 Then

         Sht1.Range(Cells(i, 1), Cells(i, 3)).Copy Sht2.Cells(J, 1)
         J = J + 1
    End If
Next i

End Sub

補足情報（FW/ツールのバージョンなど）

使用しているのはExcel2013です。

Answer 1

こんな感じでどうでしょうか。（修正しました）

Sub Macro1()

    Dim Sht1 As Worksheet
    Dim Sht2 As Worksheet
    Dim LastRow As Long
    Dim i As Long
    Dim j As Long
    Dim SearchWord As String


    SearchWord = InputBox("どこ？", "会場入力", "新宿")

    Set Sht1 = Sheets("計算用")
    Set Sht2 = Sheets(SearchWord)

    Dim arr, k
    arr = Sht1.UsedRange.Resize(1).Value
    For k = 1 To UBound(arr, 2)
        arr(1, k) = IIf(WorksheetFunction.CountIf(Sht2.Rows(2), arr(1, k)) > 0, WorksheetFunction.Match(arr(1, k), Sht2.Rows(2), False), 0)
    Next

    j = 2
    LastRow = Sht1.Cells(Rows.Count, 2).End(xlUp).Row
    For i = 2 To LastRow
        If InStr(Sht1.Cells(i, 2), SearchWord) > 0 Then
            For k = 1 To UBound(arr, 2)
                If arr(1, k) > 0 Then Sht2.Cells(j, arr(1, k)).Value = Sht1.Cells(i, k).Value
            Next
            j = j + 1
        End If
    Next i
    Sht2.Cells.Rows(3).Copy
    Sht2.Cells.Rows(3).Resize(j - 2).PasteSpecial Paste:=xlPasteFormats
    
End Sub

---

（再々々々修正）

Sub Macro2()

    Dim Sht1 As Worksheet
    Dim Sht2 As Worksheet
    Dim LastRow As Long
    Dim i As Long
    Dim j As Long
    Dim SearchWord As String


    Set Sht1 = Sheets("計算用")
    LastRow = Sht1.Cells(Rows.Count, 2).End(xlUp).Row
    For i = 2 To LastRow
        Set Sht2 = Sheets(Sht1.Cells(i, "C").Value)
        j = Sht2.Cells(Rows.Count, 2).End(xlUp).Row + 1
        Dim k, v
        For k = 2 To Sht2.Cells(2, Columns.Count).End(xlToLeft).Column
            v = WorksheetFunction.Clean(Sht2.Cells(2, k).Value)
            If WorksheetFunction.CountIf(Sht1.Rows(1), v) > 0 Then
                Sht2.Cells(j, k).Value = Sht1.Cells(i, WorksheetFunction.Match(v, Sht1.Rows(1), False)).Value
            End If
        Next k
        Sht2.Cells.Rows(3).Copy
        Sht2.Cells.Rows(j).PasteSpecial Paste:=xlPasteFormats
    Next i

    For i = 2 To LastRow
        Set Sht2 = Sheets(Sht1.Cells(i, "D").Value)
        j = Sht2.Cells(Rows.Count, 2).End(xlUp).Row + 1
        Dim k
        For k = 2 To Sht2.Cells(2, Columns.Count).End(xlToLeft).Column
            v = WorksheetFunction.Clean(Sht2.Cells(2, k).Value)
            If WorksheetFunction.CountIf(Sht1.Rows(1), v) > 0 Then
                Sht2.Cells(j, k).Value = Sht1.Cells(i, WorksheetFunction.Match(v, Sht1.Rows(1), False)).Value
            End If
        Next k
        Sht2.Cells.Rows(3).Copy
        Sht2.Cells.Rows(j).PasteSpecial Paste:=xlPasteFormats
    Next i
End Sub

Comments

[chimmy_omn]

ありがとうございます！！
できれば一つひとつ入力してコピペするのではなく、全部一括コピペできればありがたいです、、！
あとこちらをやってみたところ、実行エラー1004、worksheetfanctionクラスのMatchプロパティを取得できませんと出ました、、

[jinoji]

実行エラーを修正したつもりのMacro1と、
一括コピー（C列およびD列）に対応したつもりのMacro2です。
テストしてないのでおかしいところがあるかもしれませんが、
何をしようとしているのかをくみ取ってください。

[chimmy_omn]

何度もすみません、、macro2が実行すると
実行エラー９　インデックスが有効範囲にありませんとでます、、

[chimmy_omn]

何度も失礼いたします。
検証してみたところ、シートの名前がすべて入っていないとエラーになっていたみたいで検証ですべて入れてみたらエラーは発生しませんでした。
例えば新宿という名前のシートはあるけどその名前がC列D列にない場合もあります。その場合はそのまま何も入らずスルーしていただきたいです、、
説明不足で申し訳ありませんでした。
また大きな問題で、このすべての名前を入れる検証の作業をし、実行後はエラーが出なかったものの実行前と何も変わらない状況で、コピーが一切何もされておりませんでした、、
長々と申し訳ございません、何卒ご解明いただけたら幸いです、、

[jinoji]

おかしなところがあったので修正しました。いま一度お試しください。

[chimmy_omn]

修正頂き本当にありがとうございます＞＜
再度行ってみましたが、次は書式がおかしくなってしまったり、コピーされるところと
されないところがありました、、何度もすみません、、私も色々試しておりますが難しいです、、
実行後の結果を上に写真で追加しておきます。

[chimmy_omn]

今わかったことは利用時刻が利用時間になっているためそこは時刻に変更したら直るようになりました。
他の予約の場所などはおそらく途中でチェックという列が余分に入っているため認識されていないのかもしれません、、
また書式の行の幅や色が変わってしまうのはまだ解決できておりません＞＜

[chimmy_omn]

また、利用スポット名(C列)は内部ID、利用時刻、会場名、最短が反映されますが、
会場名(D列)で絞っていただいたもののシートは一切何もコピーがされませんでした、、

[jinoji]

書式の件は修正しました。（書式をコピーする元の行を間違えていた）
予約者氏名などがコピーされないのは、「予約者氏名」と「予約者↓氏名」と改行を含んだものが別モノとみなされるためだと思います。コピー先の見出し行を修正いただくのが近道かと。

[chimmy_omn]

内部ID、利用時刻、会場名、最短がすべて綺麗に反映されました！ありがとうございます；；
コピー先の改行のところは意味あって改行をされているようなのですが、(改行の見出し部分はチェックという文字が入ります)
改行があればやはりコピーはむずかしいでしょうか；；

[jinoji]

計算用のシートの方を同じように改行含む見出しにするのでもいいのですが。
どちらも難しいなら、何かもう一工夫必要ですね。できないことはないでしょうが。

[chimmy_omn]

改行をすべて消しても結局予約者名等は反映されませんでした＞＜；；

[chimmy_omn]

コピー先のシートを見出し改行なしで作成いたしますので改行なしで入るようなVBAをご教授いただけますでしょうか；；

[jinoji]

コピー先が改行ありでも大丈夫なように直したつもりです。一度お試しください

[chimmy_omn]

あああああ理想通りできました！！＞＜；；；本当に感謝です！！ありがとうございました＞＜！！！
私もjinojiさんのようになるため勉強して参ります＞＜本当に助かりました！！！ありがとうございました；；