| |
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
-------------------------------------------------------------------------
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
