[[20250628112619]]　『データを配列？で印刷フォームに転記』（KUN）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) |

| 全文検索 | 過去ログ ]

　

『データを配列？で印刷フォームに転記』（KUN）

どうしていいのかわからないので教えてください。
具体的な例で説明させて下さい

sheet1にデータが入っています。

名前　　区分１　明細１　明細２　明細３
山田　　野菜　　　001　　AAA 　aaa　
山田　　野菜　　　002　　BBB　　bbb

山田　　肉　　　　001　　FFF
山田　　魚　　　　001　　JJJ
山田　　果物　　　001　　QQQ
が1000件ぐらいあります。

sheet2に印刷に対応したマスに転記したいのですが・・・

　　　A　　　B　　　　C　　D　　E・・・　L（max10マス）
１　山田　　野菜　｜001｜002｜003|
２　　　　　　　　｜AAA｜BBB｜CCC|
３　　　　　　　　｜aaa｜bbb｜ccc|

４　　　　　　　　|011|
５　　　　　　　　|KKK|
６　　　　　　　　|kkk|

７　　　　　　肉　｜001|
８　　　　　　　　｜PPP|
９　　　　　　　　|ppp|
　

１マスは明細の３行使い、
区分１のデータが変われば、sheet2は次の行のマスに、
区分１（野菜）の同じデータが10以上の場合は、次の行のマスに転記
人が変わっても次の行のマスに転記していきたいです。
区分１は４種類、人は２０人位います。
sheet１のデータ（１行）をsheet2の３行に転記、
sheet１の１０データをsheet２の同じ行（３行）のマスに転記したいです。

何となく、配列を利用するのではないかと思っていますが、
実際どうすればいいのか分かりません。
上手く説明できているかも不安ですが、
どうか、手助けをお願い致します。

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

---

素朴な疑問　

003 CCC ccc　はどこにあるのだろ？　　(*^^*)

新入社員の皆様にご説明戴くように、詳細に渡る　転記規則を　手を取る様に手順を
さらに教えて戴くと、何かお手伝いくらいは出来るかもしれません。。。←　怪しい　^^;

m(__)m
（隠居Z） 2025/06/28(土) 12:18:25

---

説明が雑で申し訳ございませんでした。

名前　　区分１　明細１　明細２　明細３
山田　　野菜　　　001　　AAA 　aaa　
山田　　野菜　　　002　　BBB　　bbb
山田　　野菜　　　003　　CCC　　ccc
・・・と続いています。
山田の野菜が11データあり、sheet２のマスは２行目（実際には３行使っているので４行目）で
次が、山田の肉が次のマス行３行目（実際には７行目）・・・という感じです。

山田の野菜のデータを10個、sheet２に横に転記、11個目は次の行（下のマス）に転記。
データを10個転記、又は、区分１（野菜等）が変わる又は、人（山田）が変わったら下のマス
に転記したい。

区分はMAX４種類、人によっては１種類の場合もある
人は２０人ぐらい・・・MAX３０人です、

隠居Z様、よろしくお願いいたします。

（KUN） 2025/06/28(土) 12:43:59

---

＞＞説明が雑で申し訳ございませんでした。
　　　↑
いえいえ、こちらこそ理解力が乏しい隠居であいすみません^^;

早速のさらなるご説明、ありがとうございます。勘案してみます。暫時、御猶予を
他の回答者様のお出ましも合わせてお待ちくださいませ。でわ
m(__)m
（隠居Z） 2025/06/28(土) 13:04:38

---

こんにちわ。　＾＾；
こんなかんじですかぁ〜　違ってましたらお許しを。。。(*^^*)
お試の前には、バックアップは取ってくださいね〜
m(__)m

 Option Explicit
Sub ConvertToPrintOutFormatMatrix()
    Dim v()           As Variant
    Dim w()           As Variant
    Dim r             As Range
    Dim i             As Long
    Dim Ay            As Long
    Dim Ax            As Long
    Dim x             As Long
    Dim y             As Long
    With Worksheets("Sheet1")
        Set r = .Cells(1).CurrentRegion
    End With
    With Worksheets("Sheet2")
        .UsedRange.Clear
        r.Copy .Cells(1)
        Set r = .Cells(1).CurrentRegion
        r.Sort Key1:=r.Columns(1), Order1:=xlAscending, _
               Key2:=r.Columns(2), Order2:=xlAscending, Header:=xlYes
        v = r.Resize(r.Rows.Count + 1).Value
    End With
    ReDim w(1 To 3, 1 To 10)
    With Worksheets("Sheet2")
        .UsedRange.Clear
        .Cells(1).Resize(, 12) = Array("氏名", "区分", "F1", "F2", "F3", "F4", _
                                       "F5", "F6", "F7", "F8", "F9", "F10")
        y = 2: x = 1
        Ay = 1: Ax = 1
        For i = 2 To UBound(v, 1) - 1
            For J = 3 To 5
                w(Ay, Ax) = v(i, J)
                Ay = Ay + 1
            Next
            Ax = Ax + 1
            Ay = 1
            If v(i, 1) <> v(i + 1, 1) Or v(i, 2) <> v(i + 1, 2) Or Ax > 10 Then
                .Cells(y, x) = v(i, 1)
                .Cells(y, x + 1) = v(i, 2)
                .Cells(y, x + 2).Resize(3, 10) = w
                y = y + 4
                Ax = 1
                Ay = 1
                ReDim w(1 To 3, 1 To 10)
            End If
        Next
    End With
    Erase v, w
End Sub
（隠居Z） 2025/06/28(土) 15:20:10

---

隠居Z様

有難うございます。
やってみます。

少しお時間を下さい。
勉強しながら、やってみます。
( ..)φ　

本当にありがとうございます。
（KUN） 2025/06/28(土) 17:44:46

---

隠居Z様

ありがとうございました。
希望の形になりました。

只今、勉強中なので１つ教えてください
マクロの途中で、sheet2にデータが転記されるのですが・・・

 With Worksheets("Sheet2")
         .UsedRange.Clear
         r.Copy .Cells(1)
         Set r = .Cells(1).CurrentRegion
         v = r.Resize(r.Rows.Count + 1).Value
     End With

教えてください。
よろしくお願いいたします。

（KUN） 2025/06/29(日) 12:32:41

---

こんにちわ。　(*^^*)

 With Worksheets("Sheet2")
     Rem Sheet2の内容を書式を含め初期化します。
    .UsedRange.Clear
    Rem Sheet1の内容をA1セルを基準[範囲の左上]として貼り付けます
     r.Copy .Cells(1)
    Rem ソート用に変数rにSheet2の内容を格納します
     Set r = .Cells(1).CurrentRegion

　　ここでＡ列、Ｂ列の順で昇順並び替え^^;

    Rem 配列変数vにソート済みｒの範囲を、1行余分に[最下行は空白のダミーを作成して]格納
     v = r.Resize(r.Rows.Count + 1).Value
 End With
今回のコードの場合
一つ下の行の値と比較しますのでレンジオブジェクトならそのままエラー無く可能ですが
配列はそんな要素無いよ。とエラーに成りますので偽情報を一行必要列分余分に確保しておきます。
その為、ループ指定はデータ開始行から最大要素数-1　までです。
<< _ _ >>

（隠居Z） 2025/06/29(日) 13:10:20

---

＞＞マクロの途中で、sheet2にデータが転記されるのですが・・・

ＳＯＲＴＢＹ関数が使えるなら必要ないかもしれません。。。
様々な方法が有ると思いますので。。。↑は、ほんの一案とお考えいただければ幸甚ですA^^;
m(__)m
（隠居Z） 2025/06/29(日) 13:16:23

---

隠居Z様

ありがとうございました。
これから、たくさん勉強します。

迅速にご対応いただき
本当に感謝しております。

ありがとうございました。
（KUN） 2025/06/29(日) 13:52:23

---

 後追いの蛇足です。

 Sheet1は元データでそれには変更を加えない、というポリシーだからでしょう。
 まるごとSheet2にいったんコピーし、ソートするのが手っ取り早い(*)です。
 ソートし配列にとりこんだあとで .Clearしていますからまさに一時的に利用しているだけです。

 元データをソートしてよければコピーは不要でしょうが、
 元データはそのまま残すのが安全なので妥当なポリシーだと思います。

 (*)
 1．sortメソッドもsortオブジェクトを使う方法もいずれも、InPlace（その場で直接並び替える）のものであり、
    結果を別にコピーする機能はありません。
 2. また、ワークシート関数を使って、Sheet2からSheet1のデータのソート結果を利用することは、
    お使いのExcel2016ではできません。
（xyz） 2025/06/29(日) 14:01:18

---

 ああそうか、ソートは不要なので、と言うことならコピーは不要です。
 Sheet1から直接取ればいいだけです。
 話の前提を相手に伝わるように明記したほうがいいですよ。
（xyz） 2025/06/29(日) 14:34:17

---

＾＾；
m(__)mm(__)mm(__)m
（隠居Z） 2025/06/29(日) 15:34:39

---

＞話の前提を相手に伝わるように明記したほうがいいですよ。
誰に言ってるの。

（匿名） 2025/06/29(日) 15:45:32

---

 > マクロの途中で、sheet2にデータが転記されるのですが・・・
 > 
 > 
 >  With Worksheets("Sheet2")
 >          .UsedRange.Clear
 >          r.Copy .Cells(1)
 >          Set r = .Cells(1).CurrentRegion
 >          v = r.Resize(r.Rows.Count + 1).Value
 >      End With
 > 教えてください。
 に対するコメントですから、自ずと理解できると思います。

 > 転記されるのですが・・・・　
 と言われて後は想像して、というのは無しですよ。
 「ソートなしであればコピーは要らないと考えていいですか？」
 とかハッキリ書いて下さい、という趣旨でした。

 >ああそうか、ソートは不要なので、と言うことならコピーは不要です。
 という私のコメント内容からしても、誰に向かってのコメントなのかは分かるはずです。

（xyz） 2025/06/29(日) 16:10:54

---

皆様、隠居Z様、XYZ様

教えて頂き本当にありがとうございました。
説明が下手な点も考慮して頂き、心から感謝申し上げます。

これから、沢山、学ばせて頂きます。
よろしくお願いいたします。
（KUN） 2025/06/30(月) 10:06:55

---

この一連で聞いて良いのか、新しく聞いた方がよいのか
迷ったのですが、この一連の方が判っていただける様に思い、
続きで教えてください。

データはsheet2に

　　　A　　　B　　　　C　　D　　E・・・　L（max10マス）
１　山田　　野菜　｜001｜002｜003|
２　　　　　　　　｜AAA｜BBB｜CCC|
３　　　　　　　　｜aaa｜bbb｜ccc|

出るようなりました。↑

こそで、A1セルからL３セルにデータが有る場合に罫線を引く方法を教えて下さい。

001のデータ＝C1-C3のセルの外側に罫線が引きたいです。
なので、001のデータが□で囲まれている様にしたいです。

出来れば、Aセルの人（＝山田）が変わったら、次の人のデータの上に太目の罫線
５行目のL（MAXデータが10なので）まで引きたいです。
Aセルが変わった場合はデータの有無に関係なくMAX10のLセルまで横太罫線で

どうか、よろしくお願いいたします。

（KUN） 2025/07/02(水) 16:49:13

---

こんばんわ　(*^^*)
Sheet1情報のソートの必要性の有無と現在どの様なコードになっているのか
差し支えなければこちらにコピペしてくださいますか。
不都合が有れば、無理にとは申し上げません。

m(__)m
（隠居Z） 2025/07/02(水) 17:43:59

---

 Sheet1 の情報が下記の様な感じだとして^^;
 Option Explicit
Private Sub zddmk()
Rnd -19
    Dim w(), i&, j&, n&, a, b, c, d, e
    Dim m(), k(), dc
    Set dc = CreateObject("Scripting.Dictionary")
    ReDim m(29)
    For i = 0 To 29
        m(i) = "名前" & Format(i, "00")
    Next
    k = Array("果物", "野菜", "肉", "魚")
    With Worksheets("Sheet1")
        .UsedRange.Clear
        .Cells(1).Resize(, 5) = Array("氏名", "区分", "明細1", "明細2", "明細3")
        i = 0
        Do
            j = Int((29 - 0 + 1) * Rnd + 0)
            a = m(j)
            j = Int((3 - 0 + 1) * Rnd + 0)
            b = k(j)
            j = Int((29 - 0 + 1) + Rnd + 0)

            c = Cells(n + 1).Address
            d = Cells(n + 2).Address
            e = Cells(n + 3).Address
            n = n + 3
            dc(i) = Array(a, b, c, d, e)
            i = i + 1
            If i Mod 32 = 0 Then DoEvents
            If i > 1200 Then Exit Do
        Loop
        .Cells(2, 1).Resize(dc.Count, 5) = Application.Index(dc.items, 0, 0)
    End With
    dc.RemoveAll
End Sub

別モジュール使用として
下記のコードですが、[前回のものに恐怖の憶測と推測による
ちょい変更を加えたものに、罫線を引いてみました。]
ご希望の物とは違うかもしれませんが、何かの参考にでもなれば幸甚です。でわ
m(__)m

 Option Explicit
Sub ConvertToPrintOutFormatMatrix_Ver1000()
    Dim v()           As Variant
    Dim w()           As Variant
    Dim r             As Range
    Dim i             As Long
    Dim j             As Long
    Dim Ay            As Long
    Dim Ax            As Long
    Dim x             As Long
    Dim y             As Long
    Dim OldV1         As String
    Dim OldV2         As String
    Dim tmp           As Variant
    Dim ic            As Long
    Dim oc            As Long
    Dim jFlg          As Boolean
    With Worksheets("Sheet1")
        Set r = .Cells(1).CurrentRegion
    End With
    With Worksheets("Sheet2")
        .UsedRange.Clear
        r.Copy .Cells(1)
        Set r = .Cells(1).CurrentRegion
        r.Sort Key1:=r.Columns(1), Order1:=xlAscending, _
               Key2:=r.Columns(2), Order2:=xlAscending, Header:=xlYes
        v = r.Resize(r.Rows.Count + 1).Value
        ReDim w(1 To 3, 1 To 10)
        .UsedRange.Clear
        With .Cells(1).Resize(, 12)
            .Value = Array("氏名", "区分", "F1", "F2", "F3", "F4", _
                           "F5", "F6", "F7", "F8", "F9", "F10")
            .Borders.LineStyle = 1
        End With
        y = 2: x = 1
        Ay = 1: Ax = 1
        OldV1 = v(2, 1)
        OldV2 = v(2, 2)
        For i = 2 To UBound(v, 1) - 1
            ic = ic + 1
            For j = 3 To 5
                w(Ay, Ax) = v(i, j)
                Ay = Ay + 1
            Next
            Ax = Ax + 1
            Ay = 1
            If v(i, 1) <> v(i + 1, 1) Or v(i, 2) <> v(i + 1, 2) Or Ax > 10 Then
                tmp = v(i, 1)
                If tmp = OldV1 And y > 2 Then tmp = ""
                .Cells(y, x) = tmp
                tmp = v(i, 2)
                If tmp = OldV2 And y > 2 Then tmp = ""
                .Cells(y, x + 1) = tmp
                .Cells(y, x + 2).Resize(3, 10) = w
                Set r = .Cells(y, x + 2)
                If i + 1 = UBound(v, 1) Then jFlg = True
                DrawBordersLine r, jFlg
                y = y + 3
                oc = oc + Ax - 1
                Ax = 1
                Ay = 1
                OldV1 = v(i, 1)
                OldV2 = v(i, 2)
                ReDim w(1 To 3, 1 To 10)
            End If
        Next
    End With
    Erase v, w
    MsgBox "IN = " & ic & Chr(13) & "OUT = " & oc
End Sub
Private Sub DrawBordersLine(ByVal r As Range, ByVal lFlg As Boolean)
    Dim x             As Long
    With r
        For x = 1 To 10
            .Resize(3, x).BorderAround 1
        Next
        If .Offset(, -2).Value <> "" Then
            With .Offset(, -2).Resize(, 12).Borders(xlEdgeTop)
                .LineStyle = 1
                .Weight = xlThick
            End With
        End If
        If lFlg Then
            With .Offset(3, -2).Resize(, 12).Borders(xlEdgeTop)
                .LineStyle = 1
                .Weight = xlThick
            End With
        End If
    End With
End Sub

（隠居Z） 2025/07/02(水) 19:09:50

---

隠居Z様

対応が遅くなって申し訳ありません。

sheet１のデータはこんな感じです。

担当 区分 明細１ 明細２ 明細３
山田 野菜 001 AAA aaa
山田 野菜 002 BBB bbb
山田 野菜 003 CCC ｃｃｃ
山田 野菜 004 DDD ｄｄｄ
山田 野菜 005 EEE eee
山田 肉 001 FFF ｆｆｆ
山田 魚 001 JJJ ｊｊｊ
山田 果物 001 KKK ｋｋｋ
山田 果物 002 LLL lll
山田 果物 003 MMM mmm
山田 果物 004 NNN nnn
山田 果物 005 OOO ooo
鈴木 野菜 001 AAA aaa
鈴木 野菜 002 BBB bbb
鈴木 野菜 003 CCC ｃｃｃ
鈴木 肉 004 DDD ｄｄｄ
鈴木 肉 005 EEE eee
鈴木 肉 001 FFF ｆｆｆ
鈴木 魚 001 JJJ ｊｊｊ
鈴木 魚 001 KKK ｋｋｋ
鈴木 魚 002 LLL lll
鈴木 果物 001 MMM mmm
鈴木 果物 002 NNN nnn
鈴木 果物 003 OOO ooo
鈴木 果物 004 MMM mmm
鈴木 果物 005 NNN nnn
鈴木 果物 006 OOO ooo
鈴木 果物 007 MMM mmm
鈴木 果物 008 NNN nnn
鈴木 果物 009 OOO ooo
鈴木 果物 010 OOO ooo

ソートは必要なきです。
明細２，３はデータが有ったり、無かったりです。

迅速な対応、ありがとうございます。

これから、やってみます。
本当にありがとうございます。

（KUN） 2025/07/02(水) 21:05:35

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

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