| |
こんにちわ。
1行目と２行目を固定の項目として、３行目からデータが変更されれば、その都度Excelファイルが
作成される処理をしております。
この処理にさらに、別シート（Sheet2）のB6〜I33をコピーして、振分作成されるExcelファイル
に挿入される処理を作成しようと思います。
別シート（Sheet2）のB6〜I33は固定で全てのExcelファイルに挿入しようとしてます。
例）
題名1
題名2
データ
データ
データ
----------------------------------------------
（Sheet2）のB6〜I33
----------------------------------------------
コメント「'◆テスト」にテスト的に記入してみたのですが、思うように処理できません。
ご存知の方がおりましたら、ご教授いただきたくよろしくお願いします。
---------------------------------------------------------------------------------------------
Private Sub CommandButton1_Click()
Dim WS1 As Worksheet
Dim Tbl As Range
Dim v, i As Long, n As Long, n1 As Long
Dim myPath As String
Dim newBook As Workbook
Dim Bookname As String
Application.DisplayAlerts = False
myPath = ActiveWorkbook.Path & "\"
Set WS1 = ActiveWorkbook.Worksheets("Sheet1")
'Set Tbl = ActiveSheet.[A1].CurrentRegion '◆ A列で Sort済み
Set Tbl = WS1.[A1].CurrentRegion '◆ A列で Sort済み
n = Tbl.Rows.Count
v = Tbl.Resize(n + 1, 1).Value
n1 = 3 '◆変更
For i = 3 To n '◆変更
If v(i, 1) <> v(i + 1, 1) Then '下と違えば
With Workbooks.Add(xlWBATWorksheet) '◆変更 シート1枚のBook
Tbl.Rows("1:2").Copy .Sheets(1).[A1] '◆見出し行2行をCopy
Tbl.Rows(n1 & ":" & i).Copy .Sheets(1).[A3] '3行目へ
.Sheets(1).UsedRange.EntireColumn.AutoFit '◆挿入
Range("B23:E23").Select '◆テスト
Selection.Copy '◆テスト
Sheets("Sheet1").Select '◆テスト
ActiveSheet.Paste '◆テスト
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
|
|
ＶＢＡ初心者
- 12/5/21(月) 9:52 -
