[[20180801114437]]　『配列の格納方法と書式について』（zunzun）　ページの最後に飛ぶ

『配列の格納方法と書式について』（zunzun）

お世話になっております。
転記速度の改善のため、配列でのマクロを検討しています。

シート1に以下の6列のデータが300行程度並んでいます。
作業番号　金額　工期　ＰＭ名　客先　件名

シート2に以下の1列のデータが5行並んでいます。
ＰＭ名

シート3は、以前から使用している書式で、2行を使って1つの業務を表示
するようになっています。
作業番号　客　先　　金　額
件　　　　　　名　　工　期

ここで、シート2のＰＭ名に一致するデータをシート1から抽出して
シート3に転記を繰り返すマクロを作成ていますが、転記速度が遅いので、
改良しようと考えています。

質問1：シート3の転記先がとびとびのセルになっているが、配列の格納をどうすればよいか？

質問2：シート1の作業番号を入力しているセルには着色がされているが、配列でもその書式を継承できるのか？

以上、2点についてご教授いただければ、幸いです。
よろしくお願いいたします。

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

 >質問1：シート3の転記先がとびとびのセルになっているが、配列の格納をどうすればよいか？
 >シート2に以下の1列のデータが5行並んでいます。
 アウトプット用配列(1 To 5x2 (ヘッダーの分を用意するなら+2),1 To 3) を用意。
 シート2のデータに該当するものがシート1に存在すれば2行に分けて配列に格納。

 >シート1の作業番号を入力しているセルには着色がされているが、配列でもその書式を継承できるのか？ 
 単に配列だけは無理。

 今の「遅い」コードがあるなら提示すべき。
（seiya） 2018/08/01(水) 13:59

seiyaさん
ありがとうございます。
質問2は、了解しました。転記後に着色するようにします。

遅いコードは、以下の内容です。
先の説明では、簡便のシート1，2，3としましたが、実はグループが3つあるためシートは複数あります。
シート1＝ws1　シート2＝ws3　シート3＝ws2　と読み替えをお願いします。
それと、転記先のセル位置ですが、下記のセル位置に転記されます。

　　作業番号（B11）客先略称（C11）　金額（F11）
　　件名略称(B12）　　　　　　　　　工期（F12）

　　作業番号（B13）客先略称（C13）　金額（F13）
　　件名略称(B14）　　　　　　　　　工期（F14）

　　　　　・　　　　　　・　　　　　　　・
　　　　　・　　　　　　　　　　　　　　・

Sub 1グループ読込転記()

　Dim ws1 As Worksheet
　Dim ws2 As Worksheet
　Dim ws3 As Worksheet
　Dim lastRow As Long
　Dim x As Long
　Dim r As Long
　Dim n As Integer
　Dim r2 As Long
　Dim c2 As Integer

 Set ws1 = Worksheets(5)
 Set ws2 = Worksheets(1)
 Set ws3 = Worksheets(7)
 ws2.Range("a11:ah80").ClearContents
 ws2.Range("a11:ah80").Interior.ColorIndex = xlNone

  x = 10 'ws3出力行の初期値=10
  Do Until ws3.Cells(x, 15) = ""
  r2 = 11 'ws2出力行の初期値=11
  c2 = 2 'ws2出力列の初期値=2
  n = 0
  lastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row 'ws1のA列の最終行
  For r = 4 To lastRow 'ws1の注目行を4行目から最終行まで
  If ws1.Range("m" & r).Value = ws3.Cells(x, 15) Then 'ws1のm列(pm名)がws3のCells(x, 15)と同じなら
  r2 = 11 + 2 * n 'ws2の出力順番nの行位置
  c2 = (x - 10) * 7 + 2 'ws2の出力順番nの列位置

  ws1.Range("j" & r).Copy ws2.Cells(r2, c2) '作業番号
  ws1.Range("k" & r).Copy ws2.Cells(r2, c2 + 4)  '金額
  ws2.Cells(r2 + 1, c2 + 4).Value = ws1.Range("L" & r).Value '工期
  ws2.Cells(r2, c2 + 1).Value = ws1.Range("n" & r).Value '客先略称
  ws2.Cells(r2 + 1, c2).Value = ws1.Range("o" & r).Value '件名略称

  n = n + 1
 End If
 Next
 x = x + 1
 DoEvents
 Loop

End Sub
（zunzun） 2018/08/01(水) 14:36

 詳しく再現できないので
 元データ:Sheet1
 PMデータ:Sheet2
 転記先  :Sheet3
 で、それぞれ1行目に列項目がある。
 ということで

 Sub test()
     Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
     Dim a, b, OutPut
     Dim i As Long, ii As Long, n As Long
     Set ws1 = Sheets("sheet1") '元データ
     Set ws2 = Sheets("sheet2") 'PMデータ
     Set ws3 = Sheets("sheet3") '転記先
     a = ws1.Cells(1).CurrentRegion.Value '元データ格納
     b = ws2.Cells(1).CurrentRegion.Value 'PMデータ格納
     ReDim OutPut(1 To UBound(b, 1) * 2, 1 To 3) '転記用配列
     For i = 2 To UBound(b, 1)
         For ii = 2 To UBound(a, 1)
             If a(ii, 4) = b(i, 1) Then
                 n = n + 1 '1行目
                 OutPut(n, 1) = a(ii, 1)
                 OutPut(n, 2) = a(ii, 5)
                 OutPut(n, 3) = a(ii, 2)
                 n = n + 1 '2行目
                 OutPut(n, 1) = a(ii, 6)
                 OutPut(n, 3) = a(ii, 3)
             End If
         Next
     Next
     With ws3.Cells(1).CurrentRegion.Resize(, 3)
         .Offset(1).Clear
         .Rows(2).Resize(n).Value = OutPut
     End With
 End Sub
（seiya） 2018/08/01(水) 15:07

seiyaさん
コードの提示ありがとうございました。
試してみます。
（zunzun） 2018/08/01(水) 15:41

seiyaさん

試してみましたが、下記の●コードで「インデックスが有効範囲にありません」となってしまいます。
データ行が２行の場合には、sheet3に転記できましたが、行数が増えるとエラーになってしまいます。
改善点を教えていただければ、助かります。

　　　　　　　If a(ii, 4) = b(i, 1) Then

                 n = n + 1 '1行目
               ●OutPut(n, 1) = a(ii, 1)
                 OutPut(n, 2) = a(ii, 5)
                 OutPut(n, 3) = a(ii, 2)
                 n = n + 1 '2行目
                 OutPut(n, 1) = a(ii, 6)
                 OutPut(n, 3) = a(ii, 3)
             End If
（zunzun） 2018/08/01(水) 16:54

 Sheet1に同ＰＭ名が複数存在するのですか？

 >     ReDim OutPut(1 To UBound(b, 1) * 2, 1 To 3) '転記用配列
 を
      ReDim OutPut(1 To UBound(b, 1) * UBound(a, 1) * 2, 1 To 3) '転記用配列
 に変更してみてください。
（seiya） 2018/08/01(水) 17:11

seiyaさん

ありがとうございました。
分かりました。
Sheet1のデータ数☓2でも動きました。

ReDim OutPut(1 To UBound(a, 1) * 2, 1 To 3) '転記用配列

深謝です。
（zunzun） 2018/08/01(水) 17:34

お世話になっております。
昨日、seiyaさんから提示されたコードを改良しています。
ここで、5名のＰＭのデータを転記先のB列、I列、P列・・に並べるように下記のようにしたのですが、
ｎ＝ｎ+1としていると、2番めのＰＭの場合、行が1番めのＰＭの続きになり、階段状になってしまいます。
For i = 10 To 14　で　iが変わっても1行めから格納するには、どうしたら良いのでしょうか？
よろしくお願いいたします。

Sub test()

     Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
     Dim a, b, OutPut
     Dim i As Long, ii As Long, n As Long
     Set ws1 = Sheets("sheet1") '元データ
     Set ws2 = Sheets("sheet2") 'PMデータ
     Set ws3 = Sheets("sheet3") '転記先
     a = ws1.Cells(1).CurrentRegion.Value '元データ格納
     b = ws2.Cells(15).CurrentRegion.Value 'PMデータ格納 
     ReDim OutPut(1 To UBound(a, 1) * 2, 1 To 35) '転記用配列

     For i = 10 To 14
         For ii = 4 To UBound(a, 1)
             If a(ii, 13) = b(i, 15) Then
                 n = n + 1 '1行目
                 OutPut(n, 1 + (i - 10) * 7) = a(ii, 10)
                 OutPut(n, 2 + (i - 10) * 7) = a(ii, 14)
                 OutPut(n, 5 + (i - 10) * 7) = a(ii, 11)
                 n = n + 1 '2行目
                 OutPut(n, 1 + (i - 10) * 7) = a(ii, 15)
                 OutPut(n, 5 + (i - 10) * 7) = a(ii, 12)
             End If
         Next
     Next
     With ws3.Cells(1).CurrentRegion.Resize(, 35)
         .Offset(1).Clear
         .Rows(11).Offset(, 1).Resize(n).Value = OutPut
     End With
 End Sub
（zunzun） 2018/08/02(木) 12:00

 >                 OutPut(n, 1 + (i - 10) * 7) = a(ii, 10)
 nが行ですよ？
 1 + (i - 10) * 7 こんなことしてたら、大量のデータがあったら最終的に Subscript Out Of Rangeのエラーになりますよ？

 列は固定でいいんでしょ？

                  OutPut(n, 2) = a(ii, 10)  'B列
                            ^
（seiya） 2018/08/02(木) 12:28

seiyaさん

ありがとうございます。

ＰＭが5名いて、ＰＭ1はＢ列、ＰＭ2はＩ列、ＰＭ3はＰ列・・・に転記したく、開始行は各ＰＭとも11行目としたいのです。（下のような表です）

ＰＭ１　　　　　　　　　　　　　　ＰＭ２　　　　　　　　　　　　　　ＰＭ３
作業番号　客　先　金　額　作業番号　客　先　金　額　作業番号　客　先　金　額
件　　　　　　名　　　工　期　件　　　　　　名　　　工　期　件　　　　　　名　　工　期

このため、 1 + (i - 10) * 7を入れて、列方向への格納を考えましたが、ＰＭ２はＰＭ１の行の続きになり、11行目への転記ができませんでした。nの問題が解決できなかった次第です。

Subscript Out Of Rangeエラーの発生可能性もあるとのことであれば、各ＰＭ毎に、コードを作成すべきなのでしょうか？
（zunzun） 2018/08/02(木) 13:20

 外出中なので要点だけ。
 単に２行で並列にしたいのならnは必要無いでしょう。
 nの代わりに1,n+1を２にするだけでしょう

 11行目から転記なら
 Cells(1).CurrentRegionを
 Range("a11").CurrentRegion
 に変更とか...

（seiya） 2018/08/02(木) 14:25

seiyaさん

ありがとうございます。
nを無くしても、いいんですか。
nが行なんですよね。

混乱してきました。
配列、手強いです。

少し、詳しく教えていただけたら、幸いです。
（zunzun） 2018/08/02(木) 16:11

 各シートの状況が全く分からないので、あくまでも私の想定で2行並列表示ということで...

 Sub test()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim a, b, OutPut, t As Long
    Dim i As Long, ii As Long, n As Long
    Set ws1 = Sheets("sheet1") '元データ
    Set ws2 = Sheets("sheet2") 'PMデータ
    Set ws3 = Sheets("sheet3") '転記先
    a = ws1.Cells(1).CurrentRegion.Value '元データ格納
    b = ws2.Cells(1).CurrentRegion.Value 'PMデータ格納
    t = 1  '<-列の参照インデックス
    ReDim OutPut(1 To 2, 1 To 3 * UBound(b, 1) + t) '転記用配列
    For i = 2 To UBound(b, 1)
        For ii = 2 To UBound(a, 1)
            If a(ii, 4) = b(i, 1) Then
                OutPut(1, t + 1) = a(ii, 1)
                OutPut(1, t + 2) = a(ii, 5)
                OutPut(1, t + 3) = a(ii, 2)
                OutPut(2, t + 1) = a(ii, 6)
                OutPut(2, t + 3) = a(ii, 3)
                t = t + 3 '<-次回の基本列
            End If
        Next
    Next
    With ws3.Cells(1).CurrentRegion.Resize(, t)
        .Offset(1).Clear
        .Rows(2).Resize(2).Value = OutPut
    End With
 End Sub

 t該当行が現れた時点で設定された基本列を基準に各データを配列に配置する。
（seiya） 2018/08/02(木) 18:57

seiyaさん

おはようございます。
伝え方が良くなかったみたいです。

ＰＭが5名いて、ＰＭ毎の担当している件数は変化します。最大40件程度ですので、当初提案いただいたｎ行が必要かと・・・
今回提案頂いたｔ列を追加して、ＰＭ1の抽出が終了したら、列を移動して1行目からＰＭ2、3，4，5の抽出結果を格納するように改良してみます。
（zunzun） 2018/08/03(金) 09:31

 此方の想定との相違がかなりありそうなので、各シートの詳しいデータ構成を見なければ理解できません。
（seiya） 2018/08/03(金) 10:42

seiyaさん

下記のコードで、できました。色々とお世話になり、ありがとうございました。
実装に際して、これを元に修正します。

Sub test2()

    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim a, b, OutPut, t As Long
    Dim i As Long, ii As Long, n As Long
    Set ws1 = Sheets("sheet1") '元データ
    Set ws2 = Sheets("sheet2") 'PMデータ
    Set ws3 = Sheets("sheet3") '転記先
    a = ws1.Cells(1).CurrentRegion.Value '元データ格納
    b = ws2.Cells(1).CurrentRegion.Value 'PMデータ格納
    t = 1  '<-列の参照インデックス
    ReDim OutPut(1 To 80, 1 To 3 * UBound(b, 1) + t) '転記用配列

    For i = 2 To UBound(b, 1)
        For ii = 2 To UBound(a, 1)
            If a(ii, 4) = b(i, 1) Then
             n = n + 1 '1行目
                OutPut(n, t + 1) = a(ii, 1)
                OutPut(n, t + 2) = a(ii, 5)
                OutPut(n, t + 3) = a(ii, 2)
             n = n + 1 '2行目
                OutPut(n, t + 1) = a(ii, 6)
                OutPut(n, t + 3) = a(ii, 3)

            End If
        Next
      t = t + 3 '<-次回の基本列
      n = 0     '<-次回の基本行
    Next

    With ws3.Cells(1).CurrentRegion.Resize(, t)
        .Offset(1).Clear
        .Rows(2).Resize(16).Value = OutPut
    End With

 End Sub

（zunzun） 2018/08/03(金) 11:10

コメント返信：

[ 一覧(最新更新順) ]

[[20180801114437]] 『配列の格納方法と書式について』（zunzun） ページの最後に飛ぶ

[[20180801114437]]　『配列の格納方法と書式について』（zunzun）　ページの最後に飛ぶ