| |
▼ケメ子 さん：
>今回は、フォルダの中に40近くのファイルがあり、これらすべてのファイル名と同じ名前で（先頭に【作業】とつきます）ひな形ファイルをコピー、保存したいと思っています。
Sub Macro21()
Dim wb As Workbook
Dim strDirA As String
Dim strDirB As String
Dim wbA As Workbook
Dim wbB As Workbook
Dim sht As Worksheet
Dim shtB As Worksheet
Dim FSO As Object
Dim FC As Object
Dim F As Object
strDirA = ThisWorkbook.Path & "\A\"
strDirB = ThisWorkbook.Path & "\B\"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FC = FSO.GetFolder(strDirA).Files
AppActivate Application.Caption
Application.ScreenUpdating = False
For Each F In FC ' Aフォルダの中の
If Right(F.name, 4) = ".xls" Then ' エクセルファイルで
If FSO.FileExists(strDirB & F.name) Then ' Bフォルダに同じ名前があったら
' Step1 : Cフォルダの作業用ファイルのひな形を開く。
' その際、ひな形は「読み取り専用を推奨する」になっているので、
' このダイアログを「いいえ」（編集可能で開く）にして開く
DoEvents
SendKeys "{TAB}{ENTER}"
Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\C\雛形1.xls", ReadOnly:=False)
' Step2 : 開いたひな形に、Aフォルダと、Aフォルダと同名のBフォルダのファイル
' から転記作業を行う
Set wbB = Workbooks.Open(strDirB & F.name) ' Bフォルダのエクセルを開く
' シートのコピーは前回のもので書き直してください。
For Each shtB In wbB.Worksheets 'シートをコピー
On Error Resume Next
Set sht = wb.Worksheets(shtB.name)
If Not sht Is Nothing Then
shtB.Cells.Copy
sht.Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End If
On Error GoTo 0
Next
' Step3 ' Bフォルダに「作業」を付けて保存
Application.DisplayAlerts = False
wb.SaveAs Filename:=strDirB & "作業" & F.name, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
wb.Close
wbB.Close False
Application.DisplayAlerts = True
End If
End If
Next
Set FSO = Nothing
Application.ScreenUpdating = True
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
