Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(指定なし : 指定なし)
書き込む配列について
投稿日時: 19/07/09 16:31:21
投稿者: eco2019

お世話になっております。
 
一覧表(C6〜Q任意)があるシートから、sheet1に書き込みを行いたいと思い、試みていましたが、
途中で分からなくなってきました。
簡単に・・・と思いながら、1ページは下記です。
sheet1の1ページに一覧表の文字が4つ入ります。
任意のページにより、sheet1のページ枚数も変わります。
1ページは41行毎です。長くなり申し訳ございません。
 
Sub test()
 
For k = 6 To (Cells(Rows.Count, 3).End(xlUp).Row / 4) / 2 Step 45
 
j = 4
i = 18
 
 p1 = Cells(k, 3).Value
 p2 = Cells(k, 4).Value
 p3 = Cells(k, 6).Value
 p4 = Cells(k, 7).Value
 p5 = Cells(k, 8).Value
 p6 = Cells(k, 9).Value
 p7 = Cells(k, 11).Value
 p8 = Cells(k, 17).Value
  
 p9 = Cells(k + 1, 3).Value
 p10 = Cells(k + 1, 4).Value
 p11 = Cells(k + 1, 6).Value
 p12 = Cells(k + 1, 7).Value
 p13 = Cells(k + 1, 8).Value
 p14 = Cells(k + 1, 9).Value
 p15 = Cells(k + 1, 11).Value
 p16 = Cells(k + 1, 17).Value
  
 p17 = Cells(k + 2, 3).Value
 p18 = Cells(k + 2, 4).Value
 p19 = Cells(k + 2, 6).Value
 p20 = Cells(k + 2, 7).Value
 p21 = Cells(k + 2, 8).Value
 p22 = Cells(k + 2, 9).Value
 p23 = Cells(k + 2, 11).Value
 p24 = Cells(k + 2, 17).Value
  
 p25 = Cells(k + 3, 3).Value
 p26 = Cells(k + 3, 4).Value
 p27 = Cells(k + 3, 6).Value
 p28 = Cells(k + 3, 7).Value
 p29 = Cells(k + 3, 8).Value
 p30 = Cells(k + 3, 9).Value
 p31 = Cells(k + 3, 11).Value
 p32 = Cells(k + 3, 17).Value
  
Sheets("sheet1").Select
 
Cells(j, 4).Value = p1
Cells(j + 3, 4).Value = p2
Cells(j + 5, 4).Value = p3
Cells(j + 7, 4).Value = p4
Cells(j + 9, 4).Value = p5
Cells(j + 10, 4).Value = p6
Cells(j + 13, 5).Value = p7
Cells(j + 11, 5).Value = p8
 
Cells(j, 15).Value = p9
Cells(j + 3, 15).Value = p10
Cells(j + 5, 15).Value = p11
Cells(j + 7, 15).Value = p12
Cells(j + 9, 15).Value = p13
Cells(j + 10, 15).Value = p14
Cells(j + 13, 16).Value = p15
Cells(j + 11, 16).Value = p16
 
Cells(j + i, 4).Value = p17
Cells(j + 3 + i, 4).Value = p18
Cells(j + 5 + i, 4).Value = p19
Cells(j + 7 + i, 4).Value = p20
Cells(j + 9 + i, 4).Value = p21
Cells(j + 10 + i, 4).Value = p22
Cells(j + 13 + i, 5).Value = p23
Cells(j + 11 + i, 5).Value = p24
 
Cells(j + i, 15).Value = p25
Cells(j + 3 + i, 15).Value = p26
Cells(j + 5 + i, 15).Value = p27
Cells(j + 7 + i, 15).Value = p28
Cells(j + 9 + i, 15).Value = p29
Cells(j + 10 + i, 15).Value = p30
Cells(j + 13 + i, 16).Value = p31
Cells(j + 11 + i, 16).Value = p32
    
End Sub

回答
投稿日時: 19/07/09 17:41:24
投稿者: sk

引用:
一覧表(C6〜Q任意)があるシートから、sheet1に書き込みを行いたい

引用:
sheet1の1ページに一覧表の文字が4つ入ります。

ワークシート[一覧表]の C6 セルをトップセルとして
4 行単位で各セルの値を読み込み、ワークシート[sheet1]上に
「 1 ページにつき 2 × 2 の段組みでレイアウトされた表」
として転記したい、ということでしょうか。
 
引用:
任意のページにより、sheet1のページ枚数も変わります。
1ページは41行毎です。

引用:
For k = 6 To (Cells(Rows.Count, 3).End(xlUp).Row / 4) / 2 Step 45

 
引用:
j = 4
i = 18

引用:
Sheets("sheet1").Select
  
Cells(j, 4).Value = p1

引用:
Cells(j + 13, 5).Value = p7

引用:
Cells(j + i, 4).Value = p17

引用:
Cells(j + 13 + i, 16).Value = p31

1 ページ目における書き込み処理の流れに着目した場合、
1 段目の表の先頭行は 4 行目、最終行は 17 行目(行数は 14 行)、
2 段目の表の先頭行は 22 行目、最終行は 35 行目(同じく 14 行)
となっていますが、2 ページ目は何行目から始まることになるのでしょうか。

投稿日時: 19/07/09 21:44:56
投稿者: eco2019

skさん、メッセージ有難うございます。

引用:
ワークシート[一覧表]の C6 セルをトップセルとして
4 行単位で各セルの値を読み込み、ワークシート[sheet1]上に
「 1 ページにつき 2 × 2 の段組みでレイアウトされた表」
として転記したい、ということでしょうか。

はい、その通りです。
 
引用:
1 ページ目における書き込み処理の流れに着目した場合、
1 段目の表の先頭行は 4 行目、最終行は 17 行目(行数は 14 行)、
2 段目の表の先頭行は 22 行目、最終行は 35 行目(同じく 14 行)
となっていますが、2 ページ目は何行目から始まることになるのでしょうか。

2ページは42行から始まり、終わりは82行です。
2ページ目の1段目の表の先頭行は45行です。
このようなイメージです。
https://gyazo.com/90af1ab9c67204336032b05d2bc48730
 
https://gyazo.com/0c850c3e131acf6fc1e501e616fefb86

回答
投稿日時: 19/07/10 11:57:15
投稿者: sk

引用:
2ページは42行から始まり、終わりは82行です。
2ページ目の1段目の表の先頭行は45行です。

(標準モジュール)
---------------------------------------------------------------
Sub subWriteSheet()
     
    Const SourceTopRow As Long = 6
    Const SourceTopColumn As Long = 3
     
    '読み込み列をカンマ区切りで指定
    Const ReadColumnList As String = "3,4,6,7,8,9,17,11"
    '1つめの表における書き込み先セルのアドレスをカンマ区切りで指定
    Const WriteCellAddress As String = "D4,D7,D9,D11,D13,D14,E15,E17"
     
    Const FirstPageRow As Long = 1
    Const PageRows As Long = 41
     
    Const HorizontalTablesInPage = 2
    Const VerticalTablesInPage = 2
     
    Const TableRows As Long = 18
    Const TableColumns As Long = 11
         
    Dim wsSource As Excel.Worksheet
    Dim rngReadCell As Excel.Range
    Dim wsDestionation As Excel.Worksheet
    Dim rngWriteCell As Excel.Range
     
    Dim lngCount As Long
    Dim lngPage As Long
    Dim lngLastPage As Long
    Dim lngTablesInPage As Long
     
    Dim lngSourceRow As Long
    Dim lngSourceColumn As Long
    Dim lngSourceLastRow As Long
    Dim lngReadRowCount As Long
     
    Dim varReadColumnList As Variant
    Dim varWriteCellList As Variant
     
    Dim lngPageTopRow As Long
    Dim lngHTables As Long
    Dim lngVTables As Long
    Dim lngRowOffset As Long
    Dim lngColumnOffset As Long
    Dim strAddress As Variant
      
    '読み込み列リストを1次元配列に
    varReadColumnList = Split(ReadColumnList, ",")
    '書き込みセルリストを1次元配列に
    varWriteCellList = Split(WriteCellAddress, ",")
     
    '要素数の一致チェック
    If UBound(varReadColumnList) <> UBound(varWriteCellList) Then
        MsgBox "読み込み元の列の数と、書き込み先のセルの数が一致しません。", _
               vbCritical, _
               "設定エラー"
        Exit Sub
    End If
        
    '1ページ当たりの表の数を取得
    lngTablesInPage = HorizontalTablesInPage * VerticalTablesInPage
     
    '読み込み元シートの参照
    Set wsSource = Worksheets("一覧表")
    With wsSource
        '読み込み元シートの最終行の取得
        lngSourceLastRow = .Cells(.Rows.Count, SourceTopColumn).End(xlUp).Row
        '読み込み件数の取得
        lngReadRowCount = lngSourceLastRow - SourceTopRow + 1
        '1件未満の場合はプロシージャを抜ける
        If lngReadRowCount < 1 Then
            MsgBox wsSource.Name & "にデータがありません。", _
                   vbInformation, _
                   "データなし"
            Set wsSource = Nothing
            Exit Sub
        End If
        '書き込み先シートにおける最終ページの取得
        lngLastPage = (lngReadRowCount \ lngTablesInPage) - (lngReadRowCount Mod lngTablesInPage <> 0)
    End With
     
    '書き込み先シートの参照
    Set wsDestionation = Worksheets("sheet1")
    '全セルの値をクリア
    wsDestionation.Cells.ClearContents
     
    '読み込み行カウンタの初期化
    lngSourceRow = SourceTopRow
         
    'ページの数だけループ
    For lngPage = 0 To lngLastPage - 1
         
        'ページの先頭行の取得
        lngPageTopRow = FirstPageRow + (PageRows * lngPage)
         
        '行方向の表の数だけループ
        For lngVTables = 0 To VerticalTablesInPage - 1
             
            '行方向のオフセット値の取得
            lngRowOffset = lngPageTopRow + (TableRows * lngVTables) - 1
             
            '列方向の表の数だけループ
            For lngHTables = 0 To HorizontalTablesInPage - 1
                 
                '既に最終行まで読み込み切った場合はループを抜ける
                If lngSourceRow > lngSourceLastRow Then
                    Exit For
                End If
                 
                '列方向のオフセット値の取得
                lngColumnOffset = TableColumns * lngHTables
                 
                '書き込み先セルの数だけループ
                For lngCount = LBound(varWriteCellList) To UBound(varWriteCellList)
                     
                    '読み込み元セルの参照
                    lngSourceColumn = CLng(varReadColumnList(lngCount))
                    Set rngReadCell = wsSource.Cells(lngSourceRow, lngSourceColumn)
                     
                    '書き込み先セルの参照
                    strAddress = varWriteCellList(lngCount)
                    Set rngWriteCell = wsDestionation.Range(strAddress).Offset(lngRowOffset, lngColumnOffset)
                     
                    'デバッグ用
                    Debug.Print rngReadCell.Address(External:=True) & " -> " & rngWriteCell.Address(External:=True)
                     
                    '値の代入
                    rngWriteCell.Value = rngReadCell.Value
                     
                    Set rngWriteCell = Nothing
                    Set rngReadCell = Nothing
                Next
                 
                '読み込み行カウンタのインクリメント
                lngSourceRow = lngSourceRow + 1
            Next
        Next
    Next
     
    Set wsDestionation = Nothing
    Set wsSource = Nothing
     
End Sub
---------------------------------------------------------------
 
以上のような感じでしょうか。

回答
投稿日時: 19/07/10 21:05:12
投稿者: simple

一行をコピーする処理をひとつの固まりとみて、
それをFunction プロシージャmyCopyとして定義しておきます。
myCopy(k, r, c) の引数k、r、cは、
・転記元の行番号 k
・転記先の左上の開始セルの位置(r行、c列)
の3要素です。
 
これを利用して、メインの繰り返し処理を書けばよいかと思います。
 
skさんほどの抽象レベルはありませんが、この程度もありうるかと思います。
参考にしてください。

Dim wsSource As Worksheet
Dim wsDest   As Worksheet

Sub test()
    Dim lastRow     As Long
    Dim groupCount  As Long
    Dim j           As Long
    Dim k           As Long
    
    Set wsSource = Worksheets("一覧表")
    Set wsDest = Worksheets("Sheet1")
    wsDest.Cells.ClearContents      '転記先の初期化
    
    j = 4  '最初の転記先の先頭行
    
    lastRow = wsSource.Cells(Rows.Count, 3).End(xlUp).Row
    groupCount = (lastRow - 6) \ 4 + 1 ' 4行を1グループとしたときのグループ数。
    
    For k = 6 To (6 + 4 * groupCount - 1) Step 4
        Call myCopy(k, j, 4)
        Call myCopy(k + 1, j, 15)
        Call myCopy(k + 2, j + 18, 4)
        Call myCopy(k + 3, j + 18, 15)
        j = j + 41  ' 次のグループの書込先頭行
    Next
End Sub

' k行目のデータを、sheet1のr行c列セルを先頭とした領域に転記
Function myCopy(k As Long, r As Long, c As Long)
    With wsSource
        wsDest.Cells(r, c).Value = .Cells(k, 3).Value
        wsDest.Cells(r + 3, c).Value = .Cells(k, 4).Value
        wsDest.Cells(r + 5, c).Value = .Cells(k, 6).Value
        wsDest.Cells(r + 7, c).Value = .Cells(k, 7).Value
        wsDest.Cells(r + 9, c).Value = .Cells(k, 8).Value
        wsDest.Cells(r + 10, c).Value = .Cells(k, 9).Value
        wsDest.Cells(r + 13, c + 1).Value = .Cells(k, 11).Value
        wsDest.Cells(r + 11, c + 1).Value = .Cells(k, 17).Value
    End With
End Function

投稿日時: 19/07/11 01:26:36
投稿者: eco2019

大変遅くなりました。 skさん、simpleさん、詳しくご教授いただき有難うございます。
 
助かります。お世話になりました。