FC2ブログ

全てコピー貼付をさらに修正

2017–08–08 (Tue) 15:17
Sub 全てコピー貼付()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
MC = 0
namae1 = ActiveWorkbook.Name
kazu = Workbooks(namae1).Worksheets.Count
kazu = kazu - 3
Workbooks.Add
namae2 = ActiveWorkbook.Name
If kazu >= 1 Then
For kazu = kazu To 1 Step -1
Worksheets.Add
Next
Else
kazu = Workbooks(namae1).Worksheets.Count
For i = 3 To kazu + 1 Step -1
Worksheets(i).Delete
Next
End If

For j = 1 To Workbooks(namae1).Worksheets.Count
Workbooks(namae1).Worksheets(j).Activate
WSname = Workbooks(namae1).Worksheets(j).Name
Cells.Select
Selection.Copy
color_id = Workbooks(namae1).Worksheets(j).Tab.Color
Workbooks(namae2).Worksheets(j).Activate
ActiveSheet.Paste
Workbooks(namae2).Worksheets(j).Name = WSname
Workbooks(namae2).Worksheets(j).Tab.Color = color_id
If Workbooks(namae1).Worksheets(j).PageSetup.PrintArea = vbNullString Then
Else
area = Workbooks(namae1).Worksheets(j).PageSetup.PrintArea
With Workbooks(namae2).Worksheets(j).PageSetup
.PrintArea = Range(area).Address
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With

End If
Next
For Each nm In Workbooks(namae2).Names
If InStr(nm.Name, "Print_Area") = 0 Then
nm.Delete
End If
Next
Workbooks(namae1).Saved = True
If Workbooks(namae1).HasVBProject = True Then
MC = 1
End If
dt_path = Workbooks(namae1).Path
Workbooks(namae1).Close
On Error GoTo 0
If IsEmpty(dt_path) = True Then
Else

If MC = 0 Then
Workbooks(namae2).SaveAs (dt_path & "\" & namae1)
Workbooks(namae1).Close
Else
Workbooks(namae2).SaveAs Filename:=dt_path & "\" & namae1, FileFormat:=52
Workbooks(namae1).Close
End If
End If

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub


スポンサーサイト



« 空白抜きの文字列をコピーする | HOME |  ブックを開いて名前の定義を消す »

コメント

コメントの投稿

 
管理者にだけ表示

 | HOME | 

プロフィール

はる

Author:はる
FC2ブログへようこそ!

最新記事

最新コメント

フリーエリア

月別アーカイブ

カテゴリ

ブロとも申請フォーム

検索フォーム

RSSリンクの表示

リンク