お世話になります。Angelsです。
対象ファイルのシートをコピーし、ファイル名とシート名をプラスしたものを一つのブックとして指定フォルダに格納する方法をお教えください。よろしくお願いいたします。
フォルダ内にBook.xlsmと1 .xlsx・2.xlsx・3.xlsx・・・・等々ありそれぞれ複数シート（A・B・C・・・・）が含まれています。
Book.xlsmはsheet1・sheet2・sheet3・macro4つのシーとで構成されています。
対象ファイルをＡｃｔｉｖｅにして
下記コードを実行すると対象ファイル1.xlsxの複数シート（A・B・C・・・・）の内容が自動的に別ファイルA.xlsx・B.xlsx・C.xlsxになって同フォルダに保存されます。
同フォルダ内に対象ファイル（1 .xlsx・2.xlsx・3.xlsx・・・・）が複数ある時に対応できるよう1A.xlsx・1B.xlsx・1C.xlsx ・・2A.xlsx・2B.xlsx・2C.xlsxとなるように対象ファイル名とシート名をプラスしたものを保存ファイル名にしたいのですがどのようなコードを書けばよいのかわかりません。
Option Explicit
Sub sheets_save()
Dim strLinks As Variant
Dim i As Long, cnt As Long
Dim stDocName As String
Dim シート As Variant
' Excelリンクのみ対象とする
strLinks = _
ActiveWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)
If Not IsEmpty(strLinks) Then
cnt = UBound(strLinks)
stDocName = cnt & _
" 件の外部ブックへのリンクがあります。" & _
vbNewLine & "全て解除し、値に変換してよろしいですか？"
If MsgBox(stDocName, vbYesNo) = vbNo Then Exit Sub
For i = 1 To cnt
' アクティブブックのリンク解除
ActiveWorkbook.BreakLink _
Name:=strLinks(i), _
Type:=xlLinkTypeExcelLinks
Next i
MsgBox cnt & " 件のリンクを解除しました。", vbOKOnly
End If
For Each シート In Worksheets
If シート.Name <> "macro" Then
シート.Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & シート.Name
ActiveWorkbook.Close
End If
Next シート
End Sub
