FC2ブログ

全てコピー貼付

2017–08–07 (Mon) 19:21
全てコピー貼付を新しくしました。
上書き保存が付いており、ファイルを小さくする時に使えるようなものになっています。

Sub 全てコピー貼付()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
namae1 = ActiveWorkbook.Name
kazu = Workbooks(namae1).Worksheets.Count
kazu = kazu - 3
Workbooks.Add
namae2 = ActiveWorkbook.Name
MC = 0
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
Workbooks(namae1).Saved = True
dt_path = Workbooks(namae1).Path
If Workbooks(namae1).HasVBProject = True Then
MC = 1
End If
Workbooks(namae1).Close

On Error GoTo 0
On Error Resume Next
If IsEmpty(dt_path) = True Then
Else
If MC = 1 Then
Workbooks(namae2).SaveAs Filename:=dt_path & "\" & namae1, FileFormat:=52
Workbooks(namae1).Close
Workbooks(namae2).Close
Else
Workbooks(namae2).SaveAs Filename:=dt_path & "\", FileFormat:=51
Workbooks(namae1).Close
Workbooks(namae2).Close
End If
End If
On Error GoTo 0

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


休憩。。。


スポンサーサイト



« 深夜の妄想用…… | HOME |  深夜の妄想用……2 »

コメント

コメントの投稿

 
管理者にだけ表示

トラックバック

トラックバックURL

http://rakurakusoftnaka.blog.fc2.com/tb.php/98-501983de

⇒ この記事に対してトラックバックを送信する(FC2ブログユーザー)

 | HOME | 

プロフィール

はる

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

最新記事

最新コメント

フリーエリア

月別アーカイブ

カテゴリ

ブロとも申請フォーム

検索フォーム

RSSリンクの表示

リンク