Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


9202 / 76732 ←次へ | 前へ→

【73094】Re:データをフォーマットに記述する
発言  UO3  - 12/11/9(金) 12:25 -

引用なし
パスワード
   ▼はみりん さん:

私からもコード案を。

こんにちは

とりあえずのバージョンかも。

前提

・もしかしたら、A.xlsあるいはB.xlsがマクロブックなのかもしれませんが、
 一応、マクロブックがA.xlsやB.xlsではない場合も対応しています。
 (A.xlsやB.xlsがデータブックとしての扱いでもOKです)
・実行時にはA.xlsもB.xlsも、ともに開かれていることが前提です。
・A.xls、B.xlsの対象シート名が不明でしたので、どちらも "Sheet1" にしてあります。
・A.xls の 対象シートのA列は定時サンプル通り、【正しく連番】がふられているということを
 前提にしています。つまり、A列データの最終行のセルの値が【ユニークな車名の数】ということです。
・B.xls の 対象シートの先頭の3行(A1:B3")には、あらかじめ、任意の書式のタイトルが設定されている
 ということを前提にしています。
 (A,B列の4行目以降は、何かあってもなくても、コード内でクリアします)
・B.xls の 対象シートの C列以降右側には何もないということを前提にしています。

なぜ「とりあえず」なのかといいますと、この種のリスト、エクセル上は、一見、いいのですが
実際に印刷すると、同じ車名データが1ページ分の行数以上にあった場合や、そうではなくても
前のページと泣き別れた場合、そのページに車名がなく、いきなり型式、年のデータが印刷されます。
なので、【こういう場合は、あらためてページの最初に車名をセットしてほしい】という要望が
【おうおうにして】でてくる?

Option Explicit

Dim PageCnt As Long
Dim pgbodies As Long
Dim pgLines As Long
Dim toSh As Worksheet
Dim headR As Range

Sub Sample()
  Dim fromSh As Worksheet
  Dim x As Long
  Dim c As Range
  Dim r As Range
  
  Dim totpages As Long
  Dim totlines As Long
  Dim netdatalines As Long
  Dim cars As Long
  Dim details As Long
  Dim pgheads As Long
  Dim oldcar As String
  Dim newcar As String
  
  
  Application.ScreenUpdating = False
  
  'モジュールレベル変数の初期化
  PageCnt = 0
  pgbodies = 0
  pgLines = 0
  
  Set fromSh = Workbooks("A.xls").Sheets("Sheet1")  '転記元シート。シート名は適切なものに
  Set toSh = Workbooks("B.xls").Sheets("Sheet1")   '転記先シート。シート名は適切なものに
  
  If fromSh.Range("A2").Value <> 1 Then        '念のため
    MsgBox "転記可能データがありません"
    Exit Sub
  End If
  
  '転記先シートのページ情報取得等
  With toSh
    pgheads = 3
    .Range("A1:B" & pgheads).Copy .Range("E1")   '3行のタイトル域の保存
    Set headR = .Range("E1").CurrentRegion     '保存領域
    .Columns("A:B").Clear              '転記先領域の値、罫線、背景色等クリア
    .ResetAllPageBreaks               '改行挿入があればクリア
    .Cells(.Cells.Count).Value = 1         'ページ情報取得のためのダミー
    pgLines = .HPageBreaks(1).Location.Row - 1   '自動改行ベースのページあたり行数
    .Cells(.Cells.Count).Clear           'ダミーのクリア
    pgbodies = pgLines - pgheads          'ページあたりのヘッドを除くデータ行数
  End With
  
  With fromSh
    x = .Range("A" & .Rows.Count).End(xlUp).Row
    cars = .Cells(x, "A").Value           '車名の種類の数
    details = x - 1                 '転記すべき型式、年 の行数
    netdatalines = cars + details          '転記シートにおけるヘッド以外の行数
    '転記シートの必要ページ数
    totpages = netdatalines \ pgbodies + IIf((netdatalines Mod pgbodies) = 0, 0, 1)
    totlines = totpages * pgheads + netdatalines  '転記シートの総行数
  End With
  
  '★転記先にいったん罫線セット
  With toSh.Range("A3:B" & totlines).Borders
    .LineStyle = xlContinuous
    .Weight = xlThin
  End With
    
  '元データ抽出
  With fromSh
    For Each c In .Range("A2:A" & x)
      newcar = c.Offset(, 1).Value
      If newcar <> oldcar Then          '車名ブレーク
        PageOutput False, newcar        '車名をセット
      End If
      PageOutput False, c.Offset(, 2).Value, c.Offset(, 3).Value '型式、年をセット
      oldcar = newcar
    Next
    
    PageOutput True   '無条件出力
      
  End With
  
  With toSh
    headR.Clear        '保存した3行タイトルをクリア
    '★ 車名行の罫線削除
    Set r = .Range("A1").CurrentRegion.Columns(2).SpecialCells(xlCellTypeBlanks)
    r.Borders(xlEdgeLeft).LineStyle = xlNone
    r.Borders(xlEdgeRight).LineStyle = xlNone
    r.Borders(xlInsideVertical).LineStyle = xlNone
    Application.Goto .Range("A1")
  End With
  
  Application.ScreenUpdating = True
  MsgBox "転記終了しました"
  
End Sub

Private Sub PageOutput(func As Boolean, Optional data1 As String = "", Optional data2 = "")
'func True 無条件出力
'   False 配列がいっぱいなら出力した上でセット
  Static pV() As String
  Static px As Long
  Dim z As Long
  
  If func Then
    GoSub V2Page
  Else
    If px = pgbodies Then
      GoSub V2Page
      px = 0
    End If
    
    If px = 0 Then
      ReDim pV(1 To pgbodies, 1 To 2)
    End If
    
    px = px + 1
    
    pV(px, 1) = data1
    pV(px, 2) = data2
    
  End If
  
  Exit Sub
  
V2Page:
  PageCnt = PageCnt + 1
  z = (PageCnt - 1) * pgLines + 1
  headR.Copy toSh.Cells(z, "A")
  toSh.Cells(z + headR.Rows.Count, "A").Resize(UBound(pV, 1), UBound(pV, 2)).Value = pV
  px = 0
Return

End Sub
2 hits

【73088】データをフォーマットに記述する はみりん 12/11/8(木) 0:16 質問
【73089】Re:データをフォーマットに記述する ぶらっと 12/11/8(木) 8:18 発言
【73090】Re:データをフォーマットに記述する UO3 12/11/8(木) 11:49 発言
【73093】Re:データをフォーマットに記述する ぶりっと 12/11/9(金) 10:11 回答
【73094】Re:データをフォーマットに記述する UO3 12/11/9(金) 12:25 発言
【73095】Re:データをフォーマットに記述する ごんべえ 12/11/9(金) 13:15 発言

9202 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free