| |
▼tarny さん：
こんな感じなのかな・・・。
Sub Smpl()
Set Buf = ThisWorkbook.Sheets
Cnt = Buf.Count
ReDim CpFlg(1 To Cnt)
For I = 1 To Cnt
CpFlg(I) = False
Next
For I = 1 To Buf.Count
Set ActBook = Nothing
Tmp = Buf(I).Name
For J = 1 To Buf.Count
If Buf(J).Name Like "*" & Tmp & "*" And Not CpFlg(J) Then
If ActBook Is Nothing Then
Buf(J).Copy
Set ActBook = ActiveWorkbook
CpFlg(J) = True
Else
Buf(J).Copy , Sheets(ActBook.Sheets.Count)
CpFlg(J) = True
End If
End If
Next
If Not ActBook Is Nothing Then
Pth = ThisWorkbook.Path & "\" & Buf(I).Name & ".XLS"
If Dir(Pth) <> "" Then
If MsgBox("指定された場所にすでに同一ﾌｧｲﾙ名が存在します。【" & Buf(I).Name & ".XLS】" & vbCrLf & _
"上書きしますか") = vbYes Then
Kill Pth
ActBook.SaveAs Pth
ActBook.Close
End If
Else
ActBook.SaveAs Pth
ActBook.Close
End If
End If
Next
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
