|
こんにちわ。VBA初心者です。
ご教授下さい。
1行目と2行目を見出しとしてコピーして、1行目と2行目は固定
してExcel表に出力したいです。
'◆見出し行をCopyしてのところを[A1:A2]にしたり、Tbl.Rows(2).Copy
にしたりしても2行目だけ出力されたりしてしまいます。
一行目と二行目を常に表示させるにはどこを修正したらよろしいでしょうか。
お時間のあるときご教授お願い致します。
-------------------------------- VBA ソース ------------------------------------
Sub Lesson_Print()
Dim Tbl As Range
Dim v, i As Long, n As Long, n1 As Long
Dim myPath As String
Dim nSheet As Long
Dim newBook As Workbook
Dim Bookname As String
With Application
nSheet = .SheetsInNewWorkbook
.SheetsInNewWorkbook = 1
.DisplayAlerts = False
End With
myPath = ActiveWorkbook.Path & "\"
Set Tbl = ActiveSheet.[A1].CurrentRegion '◆ A列で Sort済み
n = Tbl.Rows.Count
v = Tbl.Resize(Tbl.Rows.Count + 1, 1).Value
n1 = 2
For i = 2 To n
If v(i, 1) <> v(i + 1, 1) Then '下と違えば
With Workbooks.Add
Tbl.Rows(1).Copy .Sheets(1).[A1] '◆見出し行をCopy
Tbl.Rows(n1 & ":" & i).Copy .Sheets(1).[A2]
.Sheets(1).UsedRange.EntireColumn.AutoFit '◆挿入
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.787)
.RightMargin = Application.InchesToPoints(0.787)
.TopMargin = Application.InchesToPoints(0.984)
.BottomMargin = Application.InchesToPoints(0.984)
.HeaderMargin = Application.InchesToPoints(0.512)
.FooterMargin = Application.InchesToPoints(0.512)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 200
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintErrors = xlPrintErrorsDisplayed
End With
Bookname = v(i, 1) '↓ A列データが日付のときはBook名をFormatする
If IsDate(Bookname) Then Bookname = Format$(v(i, 1), "yy-mm-dd")
.SaveAs myPath & v(i, 1) & ".xls",FileFormat:=XlFileFormat.xlExcel8
.Close False
End With
n1 = i + 1
End If
Next
Application.SheetsInNewWorkbook = nSheet
MsgBox "出力しました"
End Sub
---------------------------- VBA終了 ---------------------------------------------------
|
|