Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
2395 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【68256】Excel表の振り分け処理について VBA初心者 11/2/18(金) 18:12 質問[未読]
【68257】Re:Excel表の振り分け処理について kanabun 11/2/18(金) 20:04 発言[未読]
【68291】Re:Excel表の振り分け処理について VBA初心者 11/2/21(月) 9:37 お礼[未読]
【68256】Excel表の振り分け処理について
質問  VBA初心者  - 11/2/18(金) 18:12 -
引用なし
パスワード
   こんにちわ。ＶＢＡ初心者です。
ご教授下さい。


1行目と２行目を見出しとしてコピーして、１行目と２行目は固定
してExcel表に出力したいです。

'◆見出し行をCopyしてのところを[A1:A2]にしたり、Tbl.Rows(2).Copy
にしたりしても２行目だけ出力されたりしてしまいます。

一行目と二行目を常に表示させるにはどこを修正したらよろしいでしょうか。

お時間のあるときご教授お願い致します。


-------------------------------- 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

----------------------------　ＶＢＡ終了 ---------------------------------------------------
【68257】Re:Excel表の振り分け処理について
発言  kanabun  - 11/2/18(金) 20:04 -
引用なし
パスワード
   ▼VBA初心者 さん：

>1行目と２行目を見出しとしてコピーして、１行目と２行目は固定
>してExcel表に出力したいです。
>
>'◆見出し行をCopyしてのところを[A1:A2]にしたり、Tbl.Rows(2).Copy
>にしたりしても２行目だけ出力されたりしてしまいます。

>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　'◆挿入
>
>　　 （中　 略）
>
>　　Application.SheetsInNewWorkbook = nSheet
>　　
>　　MsgBox "出力しました"
>
>End Sub

この部分、こんな感じにしてみたらどうですか？

Sub Lesson_Print2()　'タイトル2行
　　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 Tbl = ActiveSheet.[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　'◆挿入

>　　 （中　 略）
>
 　　'Application.SheetsInNewWorkbook = nSheet
>　　
>　　MsgBox "出力しました"
>
>End Sub
【68291】Re:Excel表の振り分け処理について
お礼  VBA初心者  - 11/2/21(月) 9:37 -
引用なし
パスワード
   ▼kanabun さん：

VBA初心者です。

ご教授ありがとうございました。
おかげで解決致しました。

大変助かりました。ありがとうございました。

>▼VBA初心者 さん：
>
>>1行目と２行目を見出しとしてコピーして、１行目と２行目は固定
>>してExcel表に出力したいです。
>>
>>'◆見出し行をCopyしてのところを[A1:A2]にしたり、Tbl.Rows(2).Copy
>>にしたりしても２行目だけ出力されたりしてしまいます。
>
>>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　'◆挿入
>>
>>　　 （中　 略）
>>
>>　　Application.SheetsInNewWorkbook = nSheet
>>　　
>>　　MsgBox "出力しました"
>>
>>End Sub
>
>この部分、こんな感じにしてみたらどうですか？
>
>Sub Lesson_Print2()　'タイトル2行
>　　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 Tbl = ActiveSheet.[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　'◆挿入
>
>>　　 （中　 略）
>>
> 　　'Application.SheetsInNewWorkbook = nSheet
>>　　
>>　　MsgBox "出力しました"
>>
>>End Sub
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
2395 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free