[[20150412225946]]　『『データリストから担当ごとに振分』』（未熟者）　ページの最後に飛ぶ

『『データリストから担当ごとに振分』』（未熟者）

はじめまして。
VBA初心者です。色々調べてみても未熟のためVBAを完成させることができないので御教示頂けませんでしょうか。何卒よろしくお願い致します。。
明日の朝までに報告ファイルを70件ほど作成しなければなりません。
今後毎月発生する業務になります。

基になるデータから担当者ごと（ソート済）にデータを抽出し、テンプレートに転記するというマクロ処理です。

【基データ】

A　　　　 B 　C 　D 　Ｅ
1 社員名　商品No. 商品名　上司ID 　上司名　
2 あああ　0000 　ＡＡＡ　　6666 　　　 ○○
3　いいい　1111 　ＢＢＢ　 6666　　○○
4　ううう　　2222 　ＣＣＣ　 7777　　■■
5　えええ　3333 　ＤＤＤ　　8888　 △△
6　おおお　4444　ＥＥＥ　 8888 　　　 △△

　　↓

【マクロ処理後】

○○（←上司名）ファイル.xlsｘ

A 　B 　C 　D 　Ｅ　Ｆ　Ｇ
1 ○○（←上司名）
2
3
4
5
6 2015年度商品売上リスト
7
8 ××××××××××××××
9 ××××××××
10
11 ＿＿＿＿＿＿＿＿＿＿＿
12 |氏名 |商品No.|商品名∣
13 |あああ| 0000 |ＡＡＡ∣
14 |いいい| 1111 |ＢＢＢ∣ 　　　※罫線をひきたいです。
・
・
42
43

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

 >明日の朝までに報告ファイルを70件ほど作成しなければなりません。

 大変だろうとは思うけど　23:10 に投稿して、明朝までというのはないよねぇ。
 とりあえず、大急ぎで書いてみたけど・・・

 テンプレートシートを追加してください。６行目、８行目、９行目、１２行目は、あらかじめセットしておいてください。
 基シート、テンプレートシートのシート名は実際のものにしてくｄさい。

 上司別ブックをマクロブックと同じフォルダに保存します。

 Sub Test()
    Dim z As Long
    Dim x As Long
    Dim shM As Worksheet
    Dim shT As Worksheet
    Dim c As Range
    Dim nBK As Workbook

    Set shM = Sheets("Sheet1")          '基シート
    Set shT = Sheets("テンプレート")    'テンプレートシート

    z = shM.Cells(1, Columns.Count).End(xlToLeft).Column
    x = shM.Range("A" & Rows.Count).End(xlUp).Row - 1
    shM.Columns("D").Copy shM.Cells(1, z + 2)
    shM.Columns(z + 2).RemoveDuplicates Columns:=1, Header:=xlYes
    shM.Cells(1, z + 4).Value = shM.Range("D1").Value
    shM.Cells(1, z + 6).Resize(, 5).Value = shM.Range("A1:E1").Value

    For Each c In shM.Cells(1, z + 2).CurrentRegion
        If c.Row > 1 Then
            shM.Cells(2, z + 4).Value = c.Value
            shM.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
                CriteriaRange:=shM.Cells(1, z + 4).Resize(2), CopyToRange:=shM.Cells(1, z + 6).Resize(, 5), Unique:=False
            With shM.Cells(1, z + 6).CurrentRegion.Resize(, 3)
                shT.Range("A13").Resize(x, 3).ClearContents
                Intersect(.Cells, .Cells.Offset(1)).Copy shT.Range("A13")
            End With
            shT.Range("A1").Value = shM.Cells(2, z + 10).Value
            Sheets("テンプレート").Copy
            Set nBK = ActiveWorkbook
            With nBK.Sheets(1).Range("A12").CurrentRegion
                With .Borders(xlEdgeLeft)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With .Borders(xlEdgeRight)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With .Borders(xlInsideVertical)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With .Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With .Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
            End With
            Application.DisplayAlerts = False
            nBK.SaveAs ThisWorkbook.Path & "\" & shT.Range("A1").Value & ".xlsx"
            Application.DisplayAlerts = False
            nBK.Close
        End If
    Next

    shM.Cells(1, z + 2).CurrentRegion.Clear
    shM.Cells(1, z + 4).CurrentRegion.Clear
    shM.Cells(1, z + 6).CurrentRegion.Clear

 End Sub

（β） 2015/04/13(月) 00:26

βさん、取り急ぎコードを書いて下さり有難うございました。
早速、使用してみたところ、１番下の上司から作成するためか次の上司になったときに、
何行か前の上司がファイルに入ってしまうようです。

（未熟者） 2015/04/13(月) 04:03

 >１番下の上司から作成するためか

 ん？　最初の上司から、上から下に作成していますが？
 上司はD列のIDをエクセルの重複の削除機能をマクロ内で使用して
 ユニークにして、それをキーにしています。E列の名前は、結果的には
 同じIDのものの、最初の　○○　になります。（ここは、最初でも最後でも同じですよね）

（β） 2015/04/13(月) 05:38

βさん、返信が大変遅くなり申し訳ございません。
再度確認しましたら正常にファイルを作成することができました。
有難うございました。
大変助かりました。

厚かましい御願いをして大変申し訳ございませんがご教示頂けないでしょうか。

余分な空白行を削除する方法をご教示頂けないでしょうか。
色々試してみたところ、行は削除されるものの案内文が消えてしまいます。
詳細は以下になります。

表との余白
C44のみ（MAXでC43まで入る予定です。）

【案内文】
C45～C53

Range("C43").Select

   Range(Selection, Selection.End(xlUp)).Select
   Selection.SpecialCells(xlCellTypeBlanks).Select
   Selection.EntireRow.Delete
   Range("A1").Select

※こちらのコードだけで実行すると希望通りに処理しますが、
上記に記載頂いたコードに載せると行だけ消され、案内文が消えます。

大変お手数をおかけ致しますがよろしくお願いいたします。
（未熟者） 2015/04/16(木) 15:29

 案内文が下にあるという説明がなかったので。
 今から外出しますので、回答は早くて深夜。

（β） 2015/04/16(木) 15:46

βさん、コメント頂きまして有難うございます。説明不足で大変申し訳ございません。
何卒よろしくお願いいたします。

（未熟者） 2015/04/16(木) 17:31

βさん、度々申し訳ございません。
１名しかいない方のファイルが作成されないようです。
こちらも見て頂けると大変助かります。
何卒よろしくお願いいたします。
（未熟者） 2015/04/16(木) 18:36

 >１名しかいない方のファイルが作成されないようです。

 アップされた例でいえば上司■■の　ううう　のケース？
 こちらでは、ちゃんとブックが生成されていますよ。

 （未熟者） 2015/04/13(月) 04:03 で不具合の指摘があったけど、コードを変更していないのに
 （未熟者） 2015/04/16(木) 15:29 では、ＯＫだったというレスがありましたね。
 何かそちらのほうでのチェックが漏れていたのか、あるいはデータが不適切だったので、それを直してＯＫになったのか
 そこはわからないままだけど、原因は何だったのかな？

 で、１名云々も、そちらの勘違いということはありませんか？

 気になっていることがあります。同姓同名の上司の存在の可能性を考えて、ユニーク（だと思っている）上司ＩＤで名寄せ、抽出しているわけだけど
 ファイル名としては、上司名だけになる。
 コードは、再処理時に同名ファイルの上書きでメッセージがでないようにしている、いいかえれば無条件に
 上書きしている。
 ということは、名寄せ、抽出をＩＤごとにやっているのに、結局は（同姓同名の上司が存在すれば）前のものは
 上書きされてしまう。ここは、コード作成時に配慮すべきだったと反省。

 １名とか複数名ということではなく、たとえば

 ＩＤが6666、上司名が　〇〇。
 ＩＤが６６６６、上司名が　〇〇。

 こんなデータがあったとしたら、ID6666のほうが、ID６６６６のもので上書きされて消えてしまう。

 今回の原因がこれかどうかはわからないけど、これは、いかにも不都合なので以下のコードでは、勝手に保存時のファイル名を
 ６６６６_上司名.xlsx にしておきました。

 空白行の削除、要件を取り違っている可能性もありますが、試してみてください。

 Sub Test()
    Dim z As Long
    Dim x As Long
    Dim shM As Worksheet
    Dim shT As Worksheet
    Dim c As Range
    Dim nBK As Workbook
    Dim r As Range

    Application.ScreenUpdating = False

    Set shM = Sheets("Sheet1")          '基シート
    Set shT = Sheets("テンプレート")    'テンプレートシート

    z = shM.Cells(1, Columns.Count).End(xlToLeft).Column
    x = shM.Range("A" & Rows.Count).End(xlUp).Row - 1
    shM.Columns("D").Copy shM.Cells(1, z + 2)
    shM.Columns(z + 2).RemoveDuplicates Columns:=1, Header:=xlYes
    shM.Cells(1, z + 4).Value = shM.Range("D1").Value
    shM.Cells(1, z + 6).Resize(, 5).Value = shM.Range("A1:E1").Value

    For Each c In shM.Cells(1, z + 2).CurrentRegion
        If c.Row > 1 Then
            shM.Cells(2, z + 4).Value = c.Value
            shM.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
                CriteriaRange:=shM.Cells(1, z + 4).Resize(2), CopyToRange:=shM.Cells(1, z + 6).Resize(, 5), Unique:=False
            With shM.Cells(1, z + 6).CurrentRegion.Resize(, 3)
                shT.Range("A13").Resize(x, 3).ClearContents
                Intersect(.Cells, .Cells.Offset(1)).Copy shT.Range("A13")
            End With
            shT.Range("A1").Value = shM.Cells(2, z + 10).Value
            Sheets("テンプレート").Copy
            Set nBK = ActiveWorkbook
            With nBK.Sheets(1).Range("A12").CurrentRegion
                With .Borders(xlEdgeLeft)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With .Borders(xlEdgeRight)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With .Borders(xlInsideVertical)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With .Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With .Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
            End With

            With nBK.Sheets(1)
                On Error Resume Next
                Set r = .Range("C12:C43").SpecialCells(xlCellTypeBlanks)
                On Error GoTo 0
                If Not r Is Nothing Then r.EntireRow.Delete
            End With

            Application.DisplayAlerts = False
            nBK.SaveAs ThisWorkbook.Path & "\" & shM.Range("N2").Value & "_" & shM.Range("O2").Value & ".xlsx"
            Application.DisplayAlerts = False
            nBK.Close
        End If
    Next

    shM.Cells(1, z + 2).CurrentRegion.Clear
    shM.Cells(1, z + 4).CurrentRegion.Clear
    shM.Cells(1, z + 6).CurrentRegion.Clear

 End Sub

（β） 2015/04/16(木) 23:59

βさん、ご教示頂きまして有難うございました。
頂いたコードと照らし合わせてみましたら、Sheetをしなければならないところbookで指定しておりました。
何度もチェックをし、不具合を調整したところ問題なくファイルを作成することができました。
大変ご迷惑をお掛けいたしまして申し訳ございませんでした。
とても短い時間の中コードを書いて下さり、なおかつ懇切丁寧にご教示頂きまして有難うございました。
大変助かりました。

（未熟者） 2015/04/17(金) 02:39

コメント返信：

[ 一覧(最新更新順) ]

[[20150412225946]] 『『データリストから担当ごとに振分』』（未熟者） ページの最後に飛ぶ

[[20150412225946]]　『『データリストから担当ごとに振分』』（未熟者）　ページの最後に飛ぶ