ブックの各シートを新規作成したフォルダに別々のブックとして分割するサンプル
です。
もし、元のブックで別シートを参照する式が入っていたら、分割後のブックを起動
した時点でリンクを更新するか聞いてくる可能性があります。
Sub test()
Dim motowb As Workbook
Dim newwb As Workbook
Dim newfol As String
Dim ws As Worksheet
Set motowb = ThisWorkbook
newfol = CreateObject("WScript.Shell").SpecialFolders("Desktop") _
& "\" & Format(Now, "yymmdd_hhmmss")
If Dir(newfol, vbDirectory + vbReadOnly + vbHidden) <> "" Then
MsgBox newfol & "は既に存在するフォルダ名です。"
Exit Sub
Else
MkDir (newfol)
End If
Application.ScreenUpdating = False
For Each ws In motowb.Worksheets
ws.Copy
Set newwb = ActiveWorkbook
newwb.SaveAs newfol & "\" & kinsoku(ws.Name) & ".xls"
newwb.Close
Next ws
Application.ScreenUpdating = True
Set newwb = Nothing
Set motowb = Nothing
End Sub
Function kinsoku(ByVal maestr As String) As String
Dim mylen As Integer
Dim i As Integer
Dim j As Integer
Dim s As String
Dim beforearray As Variant
Dim afterarray As Variant
beforearray = Array("/", "\", "<", ">", "*", "?", """", "|", ":", ",", ";")
afterarray = Array("/", "¥", "<", ">", "*", "?", StrConv("""", 4), "|", ":", ",", ";")
mylen = Len(maestr)
For i = 1 To mylen
s = Left(Mid(maestr, i), 1)
For j = 0 To 10
If s = beforearray(j) Then
s = afterarray(j)
Exit For
End If
Next
kinsoku = kinsoku & s
Next
Erase beforearray
Erase afterarray
End Function
お礼
何度もアドバイス、ありがとうございます。 短時間でこんなコードを作成していただき、感謝しています。 さっそく使わせていただきます! 助かりました!!