[[20171204150431]] 『集計表から納品書への転記』(丸の内) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『集計表から納品書への転記』(丸の内)

 VBAで集計表から納品書への転記をを試みているのですが、集計表の店名が重複しており、その店だけの納品書への転記方法が思い浮かびません。
 sheet(納品書)はそのままプリントアウトを考えています。

sheet(集計表)

     A	            B	        C
1  店名	           品名        個数
2    東京果物店    みかんL     1000
3    東京果物店    みかんM      500
4    東京果物店    バナナL     3000
5 神奈川果物店     みかんL      400
6 神奈川果物店     みかんM      200
7 神奈川果物店     バナナL      600
8   千葉果物店     リンゴL      300
9   千葉果物店     みかんL      500
10  千葉果物店     バナナM      150

sheet(納品書1)
    A          B    
1 納品書
2 東京果物店御中 
3
4  品名     個数
5 みかんL 1000
3 みかんM  500
4 バナナL 3000

sheet(納品書2)
    A          B 
1 納品書
2 神奈川果物店御中 

4  品名     個数
5 みかんL      400
6 みかんM       200
7 バナナL     600 

sheet(納品書3)
    A          B 
1 納品書
2 千葉果物店御中 

4  品名   個数
5  リンゴL      300
6  みかんL      500
7  バナナM      150

< 使用 Excel:Excel2016、使用 OS:Windows7 >


店名が重複していなかった場合は、どうやって納品書を作成していたのでしょう?
品名は手入力で良いならば、個数はSUMIFS関数で、店名と品名が一致しているものの合計にすれば良いと思います。
(???) 2017/12/04(月) 15:48

Sub main()
    Dim c As Range, d As Range, sht As Worksheet
    For Each sht In ThisWorkbook.Worksheets
        If Left(sht.Name, 3) = "納品書" Then Application.DisplayAlerts = False: sht.Delete
    Next sht
    For Each c In Sheets("集計表").Range("A2:A" & Rows.Count).SpecialCells(xlCellTypeConstants)
        If WorksheetFunction.CountIf(Sheets("集計表").Range("A2:A" & c.Row), c.Value) = 1 Then
            Sheets.Add before:=Sheets("集計表")
            With ActiveSheet
                .Name = "納品書" & ctr + 1: ctr = ctr + 1
                .Range("A1").Value = "納品書"
                .Range("A2").Value = c.Value & "御中"
                .Range("A4").Value = "品名"
                .Range("B4").Value = "個数"
                    For Each d In Sheets("集計表").Range("A2:A" & Rows.Count).SpecialCells(xlCellTypeConstants)
                        If c.Value = d.Value Then
                            .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 2).Value = Array(d.Offset(, 1).Value, d.Offset(, 2).Value)
                        End If
                    Next d
            End With
        End If
    Next c
End Sub
(mm) 2017/12/04(月) 16:55

mmさん素晴らしいサンプルありがとうございます!!
(丸の内) 2017/12/04(月) 18:01

 mmさん、つたないことを伺います。納品書に番号を付ける部分ですが、
           With ActiveSheet
                .Name = "納品書" & ctr + 1: ctr = ctr + 1
 のctrは変数でしょうか?Dim 宣言にctrの記述がなかったので ?と思いました。
  
(丸の内) 2017/12/06(水) 11:58

そうです。宣言を忘れました。
(mm) 2017/12/06(水) 12:33

 sheet("納品書3")の左端からのシート数え番号を検索するプローシージャを作ったのですが、エラーになりうまくいきません。
 どなたかご教示下さいますか?
サンプルでは数シートですが、実際は20シート以上あるため、該当するシートの数え番号を検索するのが大変です。

 Sub test()
 Dim a As integer 
  For a = 1 To Worksheets.Count
     If Worksheets(a) = "納品書3" Then
        MsgBox Worksheets(a).Count
      End If
  Next a

 End Sub

(丸の内) 2017/12/06(水) 16:56


 Sub test()

     Dim a As Integer

     For a = 1 To Worksheets.Count
         If Worksheets(a).Name = "納品書3" Then MsgBox a
     Next a

 End Sub
(bi) 2017/12/06(水) 17:02

biさん、素早いレスありがとうございます!
助かりました。謝謝!!
(丸の内) 2017/12/06(水) 17:05

sheet(集計表)の次にsheet(請求)のひな形を追加したfileから納品書枚数と同じsheet(請求書)を後ろにコピーしたVBAを作成してみました。今のところ、問題ありませんが、もっとスマートに記述する方法あったらご教示頂けませんか?

Sub main()

    Dim c As Range, d As Range, sht As Worksheet
    Dim bb, cc, dd, ctr As Integer

    For Each sht In ThisWorkbook.Worksheets
        If Left(sht.Name, 3) = "納品書" Then Application.DisplayAlerts = False: sht.Delete
    Next sht
    For Each c In Sheets("集計表").Range("A2:A" & Rows.Count).SpecialCells(xlCellTypeConstants)
        If WorksheetFunction.CountIf(Sheets("集計表").Range("A2:A" & c.Row), c.Value) = 1 Then
            Sheets.Add before:=Sheets("集計表")
            With ActiveSheet
                .Name = "納品書" & ctr + 1: ctr = ctr + 1
                .Range("A1").Value = "納品書"
                .Range("A2").Value = c.Value & "御中"
                .Range("A4").Value = "品名"
                .Range("B4").Value = "個数"
                    For Each d In Sheets("集計表").Range("A2:A" & Rows.Count).SpecialCells(xlCellTypeConstants)
                        If c.Value = d.Value Then
                            .Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 2).Value = Array(d.Offset(, 1).Value, d.Offset(, 2).Value)
                        End If
                    Next d
            End With
        End If
    Next c

    For bb = 1 To Worksheets.Count
       If Worksheets(bb).Name = "請求" Then
          For dd = 1 To ctr
            Worksheets("請求").Copy after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = "請求" & cc + 1: cc = cc + 1
          Next dd
       Else
       End If
    Next bb

End Sub
(丸の内) 2017/12/07(木) 11:41


横から失礼します。
当社でも使いたく思い質問します。
D列、E列を増やし産地と入数を加えたいのですが改良方法を教えてもらえないでしょうか?
(市場) 2017/12/08(金) 12:10

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.