Excel VBA質問箱 IV

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

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


20452 / 76732 ←次へ | 前へ→

【61699】Re:新しいブックを作成するVBA
回答  具頭幸憲  - 09/5/28(木) 11:15 -

引用なし
パスワード
   VBAド素人さん

はじめまして具頭と申します(^0^)/

早速ご依頼のMacroを組んでみました♪
一応僕の環境では問題なかったので、
もしよろしければ是非試してみてください☆ミ

お互いVBAの勉強頑張りましょうネ!

※下記Macroを『標準モジュール』に貼り付けてください
-------------------------------------------------------------------------
Sub Macro1()

Dim OpenBooks As Integer
Dim myCrtPath As Variant
Dim myAns As Integer
Dim TargetPath As String
Dim i As Integer

'現在開かれているBookの数を数えます
OpenBooks = Workbooks.Count
If OpenBooks > 1 Then
MsgBox "※このBook以外の全てのBookを閉じてからMacroを実行してください", vbCritical
Exit Sub
End If

'カレントドライブを確認します
myCrtPath = CurDir("C")
myAns = MsgBox("『" & myCrtPath & "』" & vbCrLf & _
"に新規Bookが保存されますがよろしいですか?", vbYesNo, "Macro実行")

'カレントドライブを変更します
If myAns = vbNo Then
TargetPath = Application.InputBox _
("空欄にご希望の保存先Pathを入力してください", "保存先を入力", _
 Type:=2)
Select Case TargetPath
  Case ""
  MsgBox "処理を中断します"
  Exit Sub
  Case False
  MsgBox "処理を中断します"
  Exit Sub
  Case Else
  ChDir Path:=TargetPath
End Select
End If

'ステートメントが記載されるBook名を変更します
BookName = Application.InputBox _
("ご希望のBook名を入力してください", "保存先を入力", _
 Default:="Test", Type:=2)
Select Case BookName
  Case ""
  MsgBox "処理を中断します"
  Exit Sub
  Case False
  MsgBox "処理を中断します"
  Exit Sub
  Case Else
  ActiveWorkbook.SaveAs Filename:=BookName
End Select

i = 1
Range("A2").Select

Application.ScreenUpdating = False

'ループ処理開始
Do While ActiveCell <> ""
If ActiveCell = ActiveCell.Offset(1) Then
 '新しいBookを作成
 Workbooks.Add
  With ActiveSheet
  .Cells(1, 1).Value = "日付"
  .Cells(1, 2).Value = "ID"
  .Cells(1, 3).Value = "コメント"
  .Cells(1, 4).Value = "結果"
  .Cells(2, 1).Select
  End With
  '新しいBookへコピペ
  Workbooks(BookName).Activate
  ActiveCell.EntireRow.Select
  Selection.Copy
  '新しいBookへ貼り付け
  Workbooks(2).Activate
  ActiveSheet.Paste
  '新しいBookの名前を変更
  ActiveWorkbook.SaveAs Filename:= _
  Format(Cells(2, 1).Value, "yyyy-mm-dd" & "-" & i)
  ActiveWorkbook.Close
  i = i + 1
 ActiveCell.Offset(1).Select
End If

'ActiveCellとActiveCellの上の値は同一だが、 _
ActiveCellとActiveCellの下の値が違う場合
If ActiveCell = ActiveCell.Offset(-1) Then
 If ActiveCell <> ActiveCell.Offset(1) Then
 '新しいBookを作成
  Workbooks.Add
  With ActiveSheet
   .Cells(1, 1).Value = "日付"
   .Cells(1, 2).Value = "ID"
   .Cells(1, 3).Value = "コメント"
   .Cells(1, 4).Value = "結果"
   .Cells(2, 1).Select
  End With
  '新しいBookへ2行目以降をコピペ
   Workbooks(BookName).Activate
   ActiveCell.EntireRow.Select
   Selection.Copy
  '新しいBookへ貼り付け
   Workbooks(2).Activate
   ActiveSheet.Paste
  '新しいBookの名前を変更
   ActiveWorkbook.SaveAs Filename:= _
   Format(Cells(2, 1).Value, "yyyy-mm-dd" & "-" & i)
   ActiveWorkbook.Close
   ActiveCell.Offset(1).Select
  'このケースは一度しか出現しないので、変数iを1に戻す
   i = 1
 End If
End If

'ActiveCellとActiveCellの上下の値が違う場合
If ActiveCell <> ActiveCell.Offset(-1) Then
 If ActiveCell <> ActiveCell.Offset(1) Then
 '新しいBookを作成
  Workbooks.Add
  With ActiveSheet
   .Cells(1, 1).Value = "日付"
   .Cells(1, 2).Value = "ID"
   .Cells(1, 3).Value = "コメント"
   .Cells(1, 4).Value = "結果"
   .Cells(2, 1).Select
  End With
  '新しいBookへ2行目以降をコピペ
   Workbooks(BookName).Activate
   ActiveCell.EntireRow.Select
   Selection.Copy
  '新しいBookへ貼り付け
   Workbooks(2).Activate
   ActiveSheet.Paste
  '新しいBookの名前を変更
   ActiveWorkbook.SaveAs Filename:= _
   Format(Cells(2, 1).Value, "yyyy-mm-dd")
   ActiveWorkbook.Close
   ActiveCell.Offset(1).Select
  'このケースは一度しか出現しないので、変数iを1に戻す
   i = 1
 End If
End If
Loop

Application.ScreenUpdating = True

Workbooks(BookName).Sheets(1).Range("A1").Select
MsgBox "処理が完了しました"

End Sub
-------------------------------------------------------------------------

1 hits

【61694】新しいブックを作成するVBA VBAド素人 09/5/28(木) 3:48 質問
【61695】Re:新しいブックを作成するVBA Hirofumi 09/5/28(木) 7:58 回答
【61715】Re:新しいブックを作成するVBA VBAド素人 09/5/28(木) 22:44 お礼
【61699】Re:新しいブックを作成するVBA 具頭幸憲 09/5/28(木) 11:15 回答
【61718】Re:新しいブックを作成するVBA VBAド素人 09/5/29(金) 2:19 お礼
【61717】新しいブックを作成するVBA⇒プラスα VBAド素人 09/5/28(木) 23:08 質問
【61719】Re:新しいブックを作成するVBA⇒プラスα Hirofumi 09/5/29(金) 8:17 回答
【61734】Re:新しいブックを作成するVBA⇒プラスα VBAド素人 09/5/30(土) 13:09 質問
【61738】Re:新しいブックを作成するVBA⇒プラスα Hirofumi 09/5/30(土) 17:31 回答
【61740】Re:新しいブックを作成するVBA⇒プラスα VBAド素人 09/5/30(土) 19:13 お礼

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