[[20200523212348]]　『特定の列でシートを分けたい』（とみさと）　ページの最後に飛ぶ

『特定の列でシートを分けたい』（とみさと）

 お世話になります。
 とみさとと申します。マクロは全くの初心者です。
 スマホから投稿してますので、見づらくなってしまっていたら申し訳ありません。

 ■元シート
    A    B   C    D    E
 1 番号 名前 項目1 項目2 項目3
 2 001  あい  10    0   30
 3 002  かき  30   50    0
 4 003  さし   0   40    0
 5 004  たち  20   0   50

 上記のようなシートがあります。
 これをA・B列は全シートにコピー、C列以降は一項目ずつコピーした下記のようなシートに分けたいです。
 行数・項目列数はファイルごとに異なりますが、A・B列は共通です。

 ■シート名「項目1」
    A    B   C    D    E
 1 番号 名前 項目1 →空欄
 2 001  あい  10
 3 002  かき  30
 4 003  さし   0
 5 004  たち  20

 今までは、
 1. 元シートを項目分コピーし、シート名を変更して不要な列を削除（大体5～20シートぐらい）
 2. オートフィルターで項目列が0のものを行削除して別ブックへ保存、というふうに作業していました。

 しかし、1日に何度も作業するため、ある程度マクロで処理出来るようにしたいと思い、
 色々試して出来たものが下記のものになります（シートコピーと名前を変更するだけです…）

 最終的には0の行も削除したシートを作れるようマクロを組みたいのですが、
 今はせめて特定の列だけもコピーするようにしたいです。
 おかしなところもあるかと思いますので、改善点等もあればご教示いただけると幸いです。
 どうぞよろしくお願い致します。

 Sub シートの作成()

   Dim i As Long
   Dim sh As Worksheet

     If vbNo ＝ MsgBox("項目シートを作成しますか？", vbYesNo ＋ vbQuestion) ＝ vbNo Then Exit Sub

     For i = 3 To Cells(1, Colums.Count).End(xlToLeft).Column

       Set sh = ActiveSheet
       ActiveSheet.Copy After:=Sheets(Sheets.Count)
       ActiveSheet.Name ＝ Cells(1, 0 + i).Value
       sh.Select

     Next i

   MsgBox "作成しました", vbInformation

 End Sub

＜使用 Excel：Excel2013、使用 OS：Windows10 ＞

 参考に

 Sub シートの作成()
    Dim i As Long
    Dim sh As Worksheet

    If MsgBox("項目シートを作成しますか？", vbYesNo + vbQuestion) = vbNo Then Exit Sub
    Set sh = ActiveSheet
    For i = 3 To Cells(1, Columns.Count).End(xlToLeft).Column
        With Worksheets
            .Add(after:=.Item(.Count)).Name = sh.Cells(1, i).Value
        End With
        Union(sh.Columns(1), sh.Columns(2), sh.Columns(i)).Copy Range("A1")
    Next
    MsgBox "作成しました", vbInformation
 End Sub

（ピンク） 2020/05/23(土) 22:27

 少し修正しました。

 Sub Test2()
    Dim i As Long
    Dim sh As Worksheet

    If MsgBox("項目シートを作成しますか？", vbYesNo + vbQuestion) = vbNo Then Exit Sub
    Set sh = ActiveSheet
    For i = 3 To Cells(1, Columns.Count).End(xlToLeft).Column
        With Worksheets.Add(after:=Worksheets(Worksheets.Count))
            .Name = sh.Cells(1, i).Value
            Union(sh.Columns(1), sh.Columns(2), sh.Columns(i)).Copy .Range("A1")
            '追加シートの項目名を全て"項目1"にするのなら下の "'" を外してください。
          ' .Range("C1").Value = sh.Range("C1").Value
        End With
    Next
    sh.Activate
    MsgBox "作成しました", vbInformation
 End Sub

（ピンク） 2020/05/23(土) 23:39

 ピンク様

 返信が遅くなり、申し訳ありません。
 ご教示いただいたマクロで、希望通りのシートへ分けることが出来ました！
 ファイル毎に項目分作ってシート名変更と列の削除…という簡単な作業ではありますが、
 1日に何度もとなると結構大変でしたので、それが素早く出来て感動です。
 本当にありがとうございました！！
（とみさと） 2020/05/24(日) 22:25

コメント返信：

[ 一覧(最新更新順) ]

[[20200523212348]] 『特定の列でシートを分けたい』（とみさと） ページの最後に飛ぶ

[[20200523212348]]　『特定の列でシートを分けたい』（とみさと）　ページの最後に飛ぶ