[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『エクセル2013で作成したマクロがエクセル365で動かなくなる原因』（てす）
エクセル2013で作成したマクロがエクセル365で動かそうとすると応答しないです。
ステップ実行を行い、止まる所を確認したところ特定のシートを新規ブックにコピーする際に停止します。
詳しい方がおりましたら、教えていただけないでしょうか。
以上、よろしくお願いいたします。
' テスト Macro
'
'
Dim strAa As String '変数
Dim strBa As String '変数
Dim objCa As Object '変数
ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort.SortFields.Clear '並び替え1↓
ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort.SortFields.Add Key _
:=Range("G6:G2000"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort.SortFields.Clear '並び替え2↓
ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort.SortFields.Add Key _
:=Range("I6:I2000"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort.SortFields.Clear '並び替え3↓
ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort.SortFields.Add Key _
:=Range("H6:H2000"), SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Set objCa = CreateObject("WScript.Network")
strBa = objCa.UserName
If vbNo = MsgBox("出力していいですか？", vbYesNo) Then Exit Sub 'ウィンドウ表示
Sheets("テスト").Copy 'コピーするシート指定
FileFormat = xlAddIn8 'エクセルファイルの指定
strAa = "テスト用ファイル " & Format(Date, "yyyymmdd") '保存するファイル名
ActiveWorkbook.SaveAs Filename:="C:\Users\" & strBa & "\Desktop\" & strAa 'デスクトップ指定
ActiveWorkbook.Save '上書き保存
MsgBox "デスクトップ出力完了" 'ウィンドウ表示
Workbooks(strAa & ".xlsx").Close SaveChanges:=False '出力したファイルを閉じる
End Sub
＜ 使用 Excel：Excel2013、使用 OS：Windows10 ＞
ちなみに、提示のマクロを整理するとこんな感じになりませんか？
Sub ななしのまくろ()
Dim デスクトップパス As String
Dim MySH As Worksheet
デスクトップパス = CreateObject("WScript.Shell").SpecialFolders("Desktop")
Set MySH = ActiveWorkbook.Worksheets("テスト")
With MySH.ListObjects("テーブル1").Sort
'並べ替えの条件設定
With .SortFields
.Clear
.Add Key:=MySH.Range("H6:H2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal '並べ替え3
.Add Key:=MySH.Range("I6:I2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal '並べ替え2
.Add Key:=MySH.Range("G6:G2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal '並べ替え1
End With
'並べ替えの実行
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
If MsgBox("出力していいですか？", vbYesNo) = vbYes Then
Sheets("テスト").Copy 'シートを新規ブックへコピー
With ActiveWorkbook '←シートをコピーして出来た新規ブック
.SaveAs Filename:=デスクトップパス & "\" & "テスト用ファイル " & Format(Date, "yyyymmdd")
.Save '←なぜか、名前をつけて保存したあと、もういっかい上書き保存
.Close SaveChanges:=False '（直前に保存しているので「SaveChanges:=False」不要かも）
End With
End If
End Sub
（もこな２） 2019/06/05(水) 20:33
ご回答ありがとうございます。
ステップ実行を行ったところ
Sheets("テスト").Copy 'コピーするシート指定
FileFormat = xlAddIn8 'エクセルファイルの指定
strAa = "テスト用ファイル " & Format(Date, "yyyymmdd") '保存するファイル名
ActiveWorkbook.SaveAs Filename:="C:\Users\" & strBa & "\Desktop\" & strAa 'デスクトップ指定
ここの文でテストシートを新規ファイルにコピーを作成する際に処理中で固まってしまいます。（エラーは出ないです...）
他のPC(エクセル365以外)では上記の文で問題なく動いています...
添削ありがとうございます。
マクロ初心者の為マクロの記録をツギハギで作っていたので、文が長くなってます...
（てす） 2019/06/06(木) 08:21
Sub テスト提出用()
'
' テスト提出用Macro
'
Dim strAa As String '変数
Dim strBa As String '変数
Dim objCa As Object '変数
ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort.SortFields.Clear 'G列昇順↓(G列が最初)
ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort.SortFields.Add Key _
:=Range("G6:G2000"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort.SortFields.Clear 'I列昇順↓
ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort.SortFields.Add Key _
:=Range("I6:I2000"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort.SortFields.Clear 'H列降順↓(H列が一番最後)
ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort.SortFields.Add Key _
:=Range("H6:H2000"), SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Set objCa = CreateObject("WScript.Network")
strBa = objCa.UserName
If vbNo = MsgBox("工場提出用に変更しますか？", vbYesNo) Then Exit Sub 'ウィンドウ表示
Sheets("テスト").Copy 'コピーするシート指定
strAa = "【提出用】テスト " & Format(Date, "yyyymmdd") '保存するファイル名
ActiveWorkbook.SaveAs Filename:="C:\Users\" & strBa & "\Desktop\" & strAa 'デスクトップ指定
Selection.EntireColumn.Hidden = False '再表示
ActiveSheet.ListObjects("テーブル1").Range.AutoFilter Field:=7 '指定列全表示
Columns("A:AN").Select '列指定
Selection.EntireColumn.Hidden = False '再表示
Columns("AF:AF").Select '列指定↓
Selection.Delete Shift:=xlToLeft '列削除↓
Columns("Y:Y").Select
Selection.Delete Shift:=xlToLeft
Columns("X:X").Select
Selection.Delete Shift:=xlToLeft
Columns("W:W").Select
Selection.Delete Shift:=xlToLeft
Columns("L:L").Select
Selection.Delete Shift:=xlToLeft
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Columns("E:E").Select
Selection.Delete Shift:=xlToLeft
Columns("D:D").Select
Selection.Delete Shift:=xlToLeft
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
ActiveSheet.ListObjects("テーブル1").Range.AutoFilter Field:=4, Criteria1:= _
Array("F", "FE", "="), Operator:=xlFilterValues 'FE,F,空欄選択
Rows("7:3000").Select '7から3000までの列を選択
Selection.Delete Shift:=xlUp 'セル列削除
ActiveSheet.ListObjects("テーブル1").Range.AutoFilter Field:=4 '全てのランク表示
Range("A1").Select 'A1にカーソルを合わせる
ActiveWorkbook.Save '上書き保存
MsgBox "デスクトップ出力完了" 'ウィンドウ表示
Workbooks(strAa & ".xlsx").Close '出力したファイルを閉じる
End Sub
（てす） 2019/06/06(木) 13:22
sub test
Sheets("テスト").Copy
end sub
（マナ） 2019/06/07(金) 18:12
Sheets("テスト").Copy 'コピーするシート指定
本当にシートのコピーでフリーズするのか確認したいので、マクロでシートコピーをするのに加えて、手作業でも検証してもらえませんか？
以下は、お困りのところとは関係ないとおもわれますが、気になったので投稿しておきます。
(2)
たぶんですが、↓は意味がないような気がします
FileFormat = xlAddIn8 'エクセルファイルの指定
確かに、「xlAddIn8」はブックを保存するときに使う組み込み定数ですが、上記のように書いた場合、FileFormatという変数に18という数値を格納しているだけになるとおもいます。
https://docs.microsoft.com/ja-jp/office/vba/api/excel.xlfileformat
本当に、27-2003アドイン形式で保存したいなら
ActiveWorkbook.SaveAs _ Filename:="保存したいフォルダ" & "\" & "ファイル名", _ FileFormat:=xlAddIn8
のように、SaveAsメソッドのところで指定するのだとおもいますが、私はアドイン形式保存しようとしたことがないのでこれでよいかわかりません。
（手元のExcel2007でテストすると、なぜかxls形式で保存されました）
(3)
↓は大半の場合、問題ないと思いますが、意図的にユーザー名やデスクトップの位置？を変えた場合は、フォルダが見つからないことになりそうです。
C:\Users\" & strBa & "\Desktop\"
なので、紹介した特殊フォルダの取得方法を試されても良いのではないかと思います。
(4)
一度整理したものを整理しなおすのは正直めんどくさいのでとりあえずコード提示はしませんが、並び替えについて↓をみると、どのように整理すればよいのかヒントが掴めると思います。
http://officetanaka.net/excel/vba/tips/tips148.htm
(5）
○○.select selection.××
となっている部分について、○○.××といった記述でもちゃんと動作しますので整理してみてはいかがでしょうか
(6)
列削除している部分について、複数列をまとめて削除することもできますから、マクロの記録を取ってみてどのような記述をすればよいのか調べてみてはいかがでしょうか
（もこな２） 2019/06/08(土) 10:09
ご返信ありがとうございます。
新規ファイルへのシートコピー(何もデータが入っていない物)はマクロで問題なく動作することが
確認することができました。
また、上記のプログラムで動かしたところデスクトップにファイルが作成されており、そこから応答しない
ようになっているためプログラム内容の整理をもう少ししてみようと思います。
数時間放置してみて動作が完了するかの確認を行ってみます。。。
アドバイスや参考URLのご教授ありがとうございます！
（てす） 2019/06/10(月) 20:15
動作を軽くする為には、プログラムを簡潔にしたほうがよいのでしょうか？
教えていただけると幸いでございます。
（てす） 2019/06/10(月) 20:29
それは、リスキーダックさんの助言の結果でしょうか？
こちらは放置なら、それもよいかと思ったのですが、
サロンはマルチポスト禁止ですよ。
（マナ） 2019/06/10(月) 21:21
マルチポストの件失礼致しました。
現状のプログラムで動作確認した際に20分強との結果になります。
また、プログラム内容も少し整理してみました。
以下のプログラムでも20分強かかってしまいます・・・
Sub テスト提出用()
'
' テスト提出用Macro
'
Dim strAa As String '変数
Dim strBa As String '変数
Dim objCa As Object '変数
Dim MySH As Worksheet
ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort.SortFields.Clear 'G昇順、I昇順、H降順↓
ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort.SortFields.Add Key _
:=Range("G7:G2000"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort.SortFields.Add Key _
:=Range("I7:I2000"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort.SortFields.Add Key _
:=Range("H7:H2000"), SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("テスト").ListObjects("テーブル1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Set objCa = CreateObject("WScript.Network") '変数の定義
strBa = objCa.UserName
If vbNo = MsgBox("工場提出用に変更しますか？", vbYesNo) Then Exit Sub 'ウィンドウ表示
Sheets("テスト").Copy 'コピーするシート指定
strAa = "【提出用】テスト " & Format(Date, "yyyymmdd") '保存するファイル名
ActiveWorkbook.SaveAs Filename:="C:\Users\" & strBa & "\Desktop\" & strAa 'デスクトップ指定
Selection.EntireColumn.Hidden = False '再表示
ActiveSheet.ListObjects("テーブル1").Range.AutoFilter Field:=7 'ランク全表示
Columns("A:AN").Select '列指定
Selection.EntireColumn.Hidden = False '再表示
Range("AF:AF").Delete '列指定,削除↓
Range("W:Y").Delete
Range("L:L").Delete
Range("J:J").Delete
Range("C:F").Delete
ActiveSheet.ListObjects("テーブル1").Range.AutoFilter Field:=4, Criteria1:= _
Array("F", "FE", "="), Operator:=xlFilterValues 'FE,F,空欄選択
Rows("7:3000").Select '7から3000までの列を選択(件数多くなったら3000の数字を上げて下さい)
Selection.Delete Shift:=xlUp 'セル列削除
ActiveSheet.ListObjects("テーブル1").Range.AutoFilter Field:=4 '全てのランク表示
Range("A1").Select 'A1にカーソルを合わせる
ActiveWorkbook.Save '上書き保存
MsgBox "デスクトップ出力完了" 'ウィンドウ表示
Workbooks(strAa & ".xlsx").Close '出力したファイルを閉じる
End Sub
（てす） 2019/06/10(月) 21:39
逆にサロンで続けるなら、そのように宣言してこれ以上続けないようにしないと、マルチポスト状態が解消しません。
※この投稿の直前に確認してみましたが、サロンのほうも話が終わってないようです。
（もこな２） 2019/06/10(月) 21:47
（マナ） 2019/06/10(月) 21:56
申し訳ございません。
先ほど質問は閉じさせて頂きました。
不愉快な思いをさせてしまい申し訳ございません。
（てす） 2019/06/10(月) 22:01
マルチポストの件、申し訳ございません。
無知ですみません。
再計算を手動とはどのようなものなのでしょうか？
（てす） 2019/06/10(月) 22:07
（マナ） 2019/06/10(月) 23:06
(1)
（マナ） 2019/06/07(金) 18:12、 （もこな２） 2019/06/08(土) 10:09 の手作業～ ↑の結果はどうなりましたか？
なんで↑を確認したいかというと、シートのコピーに時間がかかるということは
(a) コピー対象のシートに外部参照したりするような複雑な数式がものすごくたくさん存在して再計算に時間がかかっている (b)オートシェイプなどがたくさんあって、再描写に時間がかかっている
なんてことが想像されますので、フリーズの（異様に時間がかかる）原因がマクロによるものなのか、コピーするシートにあるのかを切り分ける目的で聞いています。
ですので空っぽのシートで検証しても意味がありません。
データがあるはずのシートをコピーしたら空っぽのシートが出来るというなら話は別ですが・・・
(2)
今の考え方だと、シートをまるごとコピーしてから新規ブック側で加工していますが、あらかじめ新規ブックを開いておいて、1番目のシートに、必要な部分だけ値と書式を貼付するのではダメですか？
（要は数式がある場合、数式そのものでないと困るのか確認しています。）
(3)
コード整理のお手伝い。
（ステップ実行や、分からない命令をネット検索したりして、研究（コードを理解）のうえ、必要な部分だけご自身のコードに取り入れてください）
Sub テスト提出用_整理()
Dim 出力用wb As Workbook
Dim MyRNG As Range
Stop 'ブレークポイントのかわり
With ActiveWorkbook.Worksheets("テスト")
'▼元データを並び替え
With .ListObjects("テーブル1").Sort
With .SortFields
.Clear
.Add Key:=Range("G7:G2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add Key:=Range("I7:I2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Add Key:=Range("H7:H2000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
End With
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'▼出力するかユーザーに確認
If MsgBox("工場提出用に変更しますか？", vbYesNo) = vbNo Then
MsgBox "処理を中止します"
Exit Sub
End If
'▼出力用の新規ブックを用意
Set 出力用wb = Workbooks.Add
'▼手動計算に変更してから新規ブックへシートをコピー挿入
Application.Calculation = xlCalculationManual
.Copy before:=出力用wb.Worksheets(1)
End With
With 出力用wb.Worksheets(1)
.Columns("A:AN").Hidden = False '列の再表示
.AutoFilterMode = False 'オートフィルター強制解除
' テーブルを解除【どうも行列を削除するときにテーブルだとエラーになるようなのでココで解除】
'▼ 【解除せずにそのままで処理する方法は別の回答者さんをお待ちください 】
With .ListObjects(1)
Set MyRNG = .Range(1)
.Unlist
End With
'▼列削除
.Range("C:F,J:J,L:L,W:Y,AF:AF").Delete
'▼オートフィルタを設定してFE,F,空欄を【抽出】
MyRNG.AutoFilter _
Field:=4, Criteria1:=Array("F", "FE", "="), _
Operator:=xlFilterValues
'▼抽出した行を削除
.AutoFilter.Range.Cells.Offset(1).Delete Shift:=xlUp
End With
.AutoFilterMode = False 'オートフィルター強制解除
End With
With 出力用wb
'▼出力用のブックを名前をつけて保存
.SaveAs Filename:=CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
"【提出用】テスト " & Format(Date, "yyyymmdd")
'▼出力用のブックを閉じる
.Close
End With
'▼自動計算に変更してからプログラム終了
Application.Calculation = xlCalculationAutomatic
End Sub
（もこな２） 2019/06/11(火) 18:38
ご教授ありがとうございます！
〇画面の停止、自動計算を一時的に手動計算に変更をして再度行った所
処理時間があまり変化はありませんでした。
また、以前は空のシートで新規ブックへのコピーは問題なく行うことが出来たのですが
先ほど普段使用しているシート(テストシート)をコピーするだけの処理で固まってしまった為
シートの中に問題があるかと思われます・・・
〇テストシートに関しましてはSUM関数しか入っておらず、200行ほどの内容になっており重くは無いかと
思われます・・・
テストシートを参照してピポットテーブル(別シート)が入っているのですが、そちらも原因の対象に
なるのでしょうか？
〇シートに関しましては関数なしの貼り付けで問題ないと思われるので1度別シートに貼り付けるマクロを
作成して確認してみます。
〇コードの整理アドバイスありがとうございます！
コードを確認しながら入れてみます！
（てす） 2019/06/11(火) 20:18
どうも、通常のセル範囲とは違う挙動のようなので、上手くいかないのは、VBAにおけるテーブルの仕様がExcel2013からExcel2016（365）になるときに変わってしまったからとかないですかね。・・・
これが原因だった場合、Excel2007ユーザーの私には検証できないので、他の回答者さんをお待ちになられたほうがよいかもしれません。
（もこな２） 2019/06/11(火) 21:07
ご返信ありがとうございます。
既存シートのテーブルを解除してシートのコピーを行ったのですが、
結果は変わらず時間がかかってしまいます・・・
（てす） 2019/06/13(木) 16:09
もう遅いシートコピーはやめて、単純に新しいブックにコピペした方が良いと思うけど。 内部では、同じような事をしてるらしいとどこかで読んだ記憶がある。 ただ Cells.copy とか無駄なことをしそうだけど。 （BJ） 2019/06/13(木) 18:15
（もこな２） 2019/06/13(木) 18:43
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.