| |
▼はみりん さん：
私からもコード案を。
こんにちは
とりあえずのバージョンかも。
前提
・もしかしたら、A.xlsあるいはB.xlsがマクロブックなのかもしれませんが、
一応、マクロブックがA.xlsやB.xlsではない場合も対応しています。
（A.xlsやB.xlsがデータブックとしての扱いでもＯＫです）
・実行時にはA.xlsもB.xlsも、ともに開かれていることが前提です。
・A.xls、B.xlsの対象シート名が不明でしたので、どちらも "Sheet1" にしてあります。
・A.xls の 対象シートのA列は定時サンプル通り、【正しく連番】がふられているということを
前提にしています。つまり、A列データの最終行のセルの値が【ユニークな車名の数】ということです。
・B.xls の 対象シートの先頭の３行（A1:B3")には、あらかじめ、任意の書式のタイトルが設定されている
ということを前提にしています。
（A,B列の４行目以降は、何かあってもなくても、コード内でクリアします）
・B.xls の 対象シートの C列以降右側には何もないということを前提にしています。
なぜ「とりあえず」なのかといいますと、この種のリスト、エクセル上は、一見、いいのですが
実際に印刷すると、同じ車名データが１ページ分の行数以上にあった場合や、そうではなくても
前のページと泣き別れた場合、そのページに車名がなく、いきなり型式、年のデータが印刷されます。
なので、【こういう場合は、あらためてページの最初に車名をセットしてほしい】という要望が
【おうおうにして】でてくる？
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") '３行のタイトル域の保存
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 '保存した３行タイトルをクリア
'★ 車名行の罫線削除
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
|
|
UO3
- 12/11/9(金) 12:25 -
