[[20170221152645]]　『複数行毎のデータ転記について』（seda）　ページの最後に飛ぶ

『複数行毎のデータ転記について』（seda）

受注リストに入力したデータを年月で絞り込み一覧表を作成したいとお思っています。
下記の様に横一列に転記するコードを作成しましたが
文字量が多くかなり文字が小さくなり見づらいため
下記の様に転記させるにはどの様にしたら良いでしょうか。

宜しくお願い致します。

現状の一覧表への転記

1行目：受注日/支店名/取引先名/取引先コード/商品名/受注金額/発送日/備考
2行目：受注日/支店名/取引先名/取引先コード/商品名/受注金額/発送日/備考
3行目：受注日/支店名/取引先名/取引先コード/商品名/受注金額/発送日/備考
　↓続く

下記の様に転記させたい
1行目：受注日/支店名/取引先名/受注金額/発送日/備考
2行目：　　　　　　　取引先コード
3行目：　　　　　　　商品名
4行目：受注日/支店名/取引先名/受注金額/発送日/備考
5行目：　　　　　　　取引先コード
6行目：　　　　　　　商品名
7行目：受注日/支店名/取引先名/受注金額/発送日/備考
8行目：　　　　　　　取引先コード
9行目：　　　　　　　商品名
　↓続く

Option Explicit
Sub 転記()

    Dim myCri As String
    Dim myRow As Long
    Dim sh2 As Worksheet, Sh3 As Worksheet
    Dim sh_name As String
    Dim n As Long
    Dim i As Long
    Dim ws As Worksheet
    Dim wsLastrow As Long

        sh_name = myCri
        ActiveSheet.Copy After:=ActiveSheet

        On Error Resume Next
        ActiveSheet.Name = sh_name
        n = 1
        Do Until Err.Number = 0
        Err.Clear
        n = n + 1
        Loop

       Set Sh3 = ActiveSheet
       Set sh2 = Worksheets("受注リスト")

       If sh2.AutoFilterMode Then
       sh2.AutoFilterMode = False
       End If

        myCri = InputBox("年月を入力　例）201702")
        Sh3.Name = myCri
        Range("E1") = myCri
        Range("E1").NumberFormatLocal = "0000年00月分"

       With sh2
            .Range("A1").AutoFilter Field:=15, Criteria1:=myCri
             myRow = .Range("A" & Rows.Count).End(xlUp).Row

            .Range("P2:P" & myRow).Copy
            Sh3.Range("B4").PasteSpecial xlPasteValuesAndNumberFormats ’受注日

            .Range("J2:J" & myRow).Copy
            Sh3.Range("C4").PasteSpecial Paste:=xlPasteValues ’支店名

            .Range("Z2:Z" & myRow).Copy
            Sh3.Range("D4").PasteSpecial Paste:=xlPasteValues ’取引先名

            .Range("K2:K" & myRow).Copy
            Sh3.Range("E4").PasteSpecial Paste:=xlPasteValues’取引先コード

            .Range("Q2:Q" & myRow).Copy
            Sh3.Range("F4").PasteSpecial Paste:=xlPasteValues ’商品名

            ※※中省略※※※

            .Range("J2:J" & myRow).Copy
            Sh3.Range("R4").PasteSpecial Paste:=xlPasteValues ’受注金額

            .Range("X2:X" & myRow).Copy
            Sh3.Range("S4").PasteSpecial Paste:=xlPasteValues  ’発送日

            .Range("Y2:Y" & myRow).Copy
            Sh3.Range("T4").PasteSpecial Paste:=xlPasteValues   ’備考

            Application.CutCopyMode = False
            Rows.Hidden = False
      End With

End Sub

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

 コードは、まだしっかりと読んでいませんし質問内容も今から読みますが、
 その前に、このコードは【本物】ですか？

    Dim myCri As String

 とあって、この myCri に何も格納しないまま　sh_name = myCri　した上で　ActiveSheet.Name = sh_name
 シートに""という名前を与えますので当然エラーですね。　で、On Error Resume Next で、その下に行って
 Err.Number(最初は 0 じゃないですね）が 0 になるまでループ。ループ処理内で Err.Clear にしていますので
 次には　0 になってループ脱出。

 いったい、何を、何のために処理しているのですか？？？？

 追加で。

 このマクロを実行する時点の ActiveSheet は、何でしょうか？

（ β） 2017/02/21(火) 15:37

 上記の疑問はありますが、要望を実現する１つの方法として提案です。
 マクロ実行時点の ActiveSheetが不明なので、それが明確になれば、もう少し手順がすっきりするかもしれませんが。

 １．work という名前の作業シートをつくっておきます。
 　　これは非表示シートにしておきましょう。
 　　この B1 ～T1 に、現在、受注リストシートから抽出している列の列タイトルをセットしておきます。
 　　（マクロ内で生成することも可能ですが）
 　　各列の書式は標準でＯＫ。
 ２．結果シートをつくっておきます。３行目までに必要なタイトル等があるのでしょうから、それをいれておきます。
 　　この４行目以降、２行１セットでﾃﾞｰﾀを転記するわけですが、このシートの各列の表示書式は、あらかじめ
 　　セットしておきましょう。（コードでは値だけをセットしましょう）
 　　★ここも、いやだ！　ということなら　マクロで書式の自動設定は可能ですが）
 ３．で、コードですけど、現在のオートフィルター処理ではなくフィルターオプションを使いましょう。
 　　・受注リストから指定日で抽出。抽出結果は直接 work シートに書き込みましょう。
 　　・抽出がなければデータがないといったメッセージを出して終了
 　　・抽出があれば、work に抽出された各行を　抽出結果シートに　２行に分けて転記しましょう。
　　　（配列に入れておいて一括転記がおすすめですが、難しければセル毎の値転記で）

（ β） 2017/02/21(火) 16:00

 β様

お返事ありがとうございました。

受注リストと一覧表というシートがあって、ActiveSheetは一覧表のつもりでいました。
myCriはフィルタをかける際の年月で、入力した年月でフィルタをかけ
一覧表が複製されシート名が入力した年月となる。

というのを色々調べながら作成したのですが
偶然たまたま動いてしまっているようですね・・・
勉強不足ですみません。

上記の方法で試してみたいと思います。

ありがとうございます。
（seda） 2017/02/21(火) 16:15

あ、βさんが書いて下さってる方法でコード書いちゃいましたので、
貼り付けておきます。
（データが無かった時の処理は省略してます。というか忘れてました＾＾；；）

こういう場合は「フィルターオプション」(=AdvancedFilterメソッド）が、
便利です。で、作業列とか作業シートとか噛ませると、
割と処理がすっきりしますので、方法として覚えておくと色々応用が効く
と思います。

元のデータシート＞

          [A]     [B]    [C]    [D]     [E]     [F]   [G]      [H]      [I]

    1]   受注日   支店  取引先  取引    商品    商品  受注    発送日    備考  
                   名   コード  先名   コード    名   金額

    2]  2017/2/1   あ     か     か   0000-01    1    100    2017/2/8

    3]  2017/2/1   う     ち     ち   0000-08    8    200   2017/2/15    ※

    4]  2017/2/1   お     ふ     ふ   0000-15    15   300   2017/2/22

    5]  2017/2/2   い     さ     さ   0000-02    2    200    2017/2/9    ※

    6]  2017/2/2   え     に     に   0000-09    9    300   2017/2/16

    7]  2017/2/2   あ     け     け   0000-16    16   100   2017/2/23

    8]  2017/2/3   う     た     た   0000-03    3    300   2017/2/10

    9]  2017/2/3   お     ひ     ひ   0000-10    10   100   2017/2/17

   10]  2017/2/3   い     せ     せ   0000-17    17   200   2017/2/24

   11]  2017/2/4   え     な     な   0000-04    4    100   2017/2/11

   12]  2017/2/4   あ     く     く   0000-11    11   200   2017/2/18

   13]  2017/2/4   う     て     て   0000-18    18   300   2017/2/25    ※

   14]  2017/2/5   お     は     は   0000-05    5    200   2017/2/12

   15]  2017/2/5   い     す     す   0000-12    12   300   2017/2/19    ※

   16]  2017/2/5   え     ね     ね   0000-19    19   100   2017/2/26

   17]  2017/2/6   あ     き     き   0000-06    6    300   2017/2/13    ※

   18]  2017/2/6   う     つ     つ   0000-13    13   100   2017/2/20

   19]  2017/2/6   お     め     め   0000-20    20   200   2017/2/27    ※

   20]  2017/2/7   い     し     し   0000-07    7    100   2017/2/14

   21]  2017/2/7   え     ぬ     ぬ   0000-14    14   200   2017/2/21    ※

作業用シート＞

      [A]       [B]       [C]           [D]     [E]       [F]     [G]

  1]  受注日

  2]  2017/2/2

3]

  4]  支店名    取引先名  取引先コード  商品名  受注金額  発送日  備考

となっているとして、
「一覧」シートに出力します。
（「作業用」シートは非表示にして運用してもいいと思います。）

Option Explicit

Sub test()

    Dim rngOld As Range         '元のデータ範囲
    Dim rngFilter As Range      '抽出した結果範囲
    Dim rngCriteria As Range    '抽出条件セル範囲
    Dim rngFrom As Range        'コピーする元の範囲（抽出した行毎）
    Dim rngTo As Range          '貼付先範囲
    Dim sDate As String

    Set rngOld = Sheets("元データ").Range("A1").CurrentRegion
    Set rngFilter = Sheets("作業用").Range("A4:G4")
    Set rngCriteria = Sheets("作業用").Range("A1:A2")

    '日付の入力
    sDate = InputBox("日付")
    If StrPtr(sDate) = 0 Then Exit Sub
    rngCriteria.Cells(2).Value = sDate

    'データの抽出
    rngOld.AdvancedFilter _
            Action:=xlFilterCopy, CriteriaRange:=rngCriteria, CopyToRange:=rngFilter
    With rngFilter.CurrentRegion
        Set rngFilter = Intersect(.Cells, .Offset(1))
    End With

    'データを整形して転記
    Sheets("一覧").UsedRange.ClearContents
    Set rngTo = Sheets("一覧").Range("A1").Resize(3, 5)
    For Each rngFrom In rngFilter.Rows
        rngTo(1, 1).Value = rngFrom.Cells(1).Value
        rngTo(1, 2).Value = rngFrom.Cells(2).Value
        rngTo(2, 2).Value = rngFrom.Cells(3).Value
        rngTo(3, 2).Value = rngFrom.Cells(4).Value
        rngTo(1, 3).Value = rngFrom.Cells(5).Value
        rngTo(1, 4).Value = rngFrom.Cells(6).Value
        rngTo(1, 5).Value = rngFrom.Cells(7).Value

        '次の転記先
        Set rngTo = rngTo.Offset(rngTo.Rows.Count)
    Next
End Sub

できれば、回答者が動作確認出来るように
質問者さんの方でデータを用意していただけると
ありがたいです。
（動作確認しないで空で間違いのないコード書ける人は、
上級者でもなかなかないと思います。）

（まっつわん） 2017/02/21(火) 16:45

あ、追記。
フィルターオプションのいいところは、
要らない列は省略できますし、
列の順番の入れ替えも容易なところです＾＾

（まっつわん） 2017/02/21(火) 16:48

まっつわん様

御親切にありがとうございます。
動作確認してみた所、下記の所で実行時エラー1004が出てしまいます。
何故でしょうか・・・？

 rngOld.AdvancedFilter _
            Action:=xlFilterCopy, CriteriaRange:=rngCriteria, CopyToRange:=rngFilter
（seda） 2017/02/22(水) 16:34

コメント返信：

[ 一覧(最新更新順) ]

[[20170221152645]] 『複数行毎のデータ転記について』（seda） ページの最後に飛ぶ

[[20170221152645]]　『複数行毎のデータ転記について』（seda）　ページの最後に飛ぶ