[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『実行時エラー及び、記載コードの意味をご教授下さい。』（いぬまねき）
遠方に転勤された方が作ったマクロです。
最近、下記エラーが発生して困っています。デバックで該当するコードも記載致します。エラーの意味とコードの意味をご教授願いたく思いました。
意味が分かったら、自分で考えてみようと思います。
・エラー：実行エラー 1004
RangeクラスのSortメゾットが失敗しました。
・エラー部分を示すコード
Worksheets(sn).Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _SortMethod:=xlPinYin, DataOption1:=xlSortNormal
よろしくお願い致します。
（いぬまねき）
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
Keyの方にシートの指定がないですが、そこは大丈夫ですか？
>遠方に転勤された方が作ったマクロです。
この方には聞いてみましたか？ （通りすがり） 2022/08/10(水) 14:18
あと、よくある質問で前任者のマクロがエラーになる、 あるいは改造したい、というのがあります。
社内でのマクロ作成のルールはありますか？ ルールはなく、前任者の作ったマクロが便利だから なんとなく使ってた、ということなら、自分でメンテナンス できないならさっさと捨てて手作業に戻す、ということも 選択肢の一つです。
それか、頑張ってマクロを勉強するか。
参考HPです。
https://kashikeiei.org/business_improvement/way_of_thinking/excel_macro/
（通りすがり） 2022/08/10(水) 14:24
エラーの原因がエラーの出ている箇所にあるとは限りません
>最近、下記エラーが発生して困っています 最近、なにか運用を変えたのでは？
気になる点はシートの指定です
Worksheets(sn).Range("A1").CurrentRegion.Sort Key1:=Range("A1")
↑
ここ
この行が実行されるとき、アクティなシートはどうなってますか？ 変数snで指定されているシートがアクティな状態で実行してもエラーがでますか？ （´・ω・`） 2022/08/10(水) 14:37
ご連絡ありがとうございます。
それより、先ほど、通りすがり様に対しての私のコメントがアップされていないのは？？
＞ Worksheets(sn).Range("A1").CurrentRegion.Sort Key1:=Range("A1")
＞この行が実行されているときのアクティブシートはどうなっていますか？
シートは、1枚しかないので、この1枚のシートがアクティブだと思っています。
それとも、アクティブではないのですかね？
（いぬまねき） 2022/08/10(水) 14:47
申し訳ありません。
アップされていないので、再度ご連絡致します。
マクロの社内ルールはありません。
多くの方が、このシートを使っているので、慣れていることもあり、これを修復したいです。
再度、最初からマクロを記載します。
Private Sub CommandButton1_Click()
UserForm2.Hide
'更新中ウィンドウの表示
UserForm1.Show vbModeless
UserForm1.Repaint
'リストを更新に適した状態に整える
Dim sn As String
sn = "リスト"
On Error Resume Next
Worksheets(sn).ShowAllData
On Error GoTo 0
Worksheets(sn).ListObjects("リスト1").ShowTotals = False
Worksheets(sn).Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
以下にも続きますが、ここで一段落しています。
（いぬまねき） 2022/08/10(水) 14:51
>私のコメントがアップされていないのは？？ 人のせいにしてはいけません。 「ページの更新ボタン」をクリックしていないからです。 （・・・） 2022/08/10(水) 15:03
そうですね。
ページ更新ボタンをクリックしなかったのですね。
（いぬまねき） 2022/08/10(水) 15:06
ご連絡ありがとうございます。
＞もしかしてA列でセル結合していたりとか
→あいにく、A列でセル結合はありませんでした。
ただ、フィルター機能で気になるところを見つけました。
データーは、A1セルからH836セルまであり、A列からH列までフィルター設定されているのですが、
フィルターオプションの設定で、抽出先が選択範囲内、リスト範囲指定が$A$678:$H$836となっていました。これは、関係ありませんか？
段々と初心者レベルになってきました。
（いぬまねき） 2022/08/10(水) 15:45
最初のご質問のお答えがまだでした。
申し訳ありません。
＞この方には聞いてみましたか？
→海外に転勤されたので、聞けない状態です。
マクロの勉強は、難しそうですが頑張ります。
（いぬまねき） 2022/08/10(水) 16:25
それは多分関係ないでしょう。
Worksheets(sn).ShowAllData
が実行されていますから。
念のためですが、
Dubug.Print Worksheets(sn).Range("A1").CurrentRegion.Address
とするとイミディエイトウインドウには何が表示されますか？
（γ） 2022/08/10(水) 16:32
お世話になります。
申し訳ありません。夏季休暇を頂き留守いたので対応が遅れました。
ご連絡、ありがとうございます。
エラー部の頭にご教授の一行を追加してみたところ、
実行時エラー'424'
オブジェクトが必要です。
と表示しました。
以下、コードを示します。
Private Sub CommandButton1_Click()
UserForm2.Hide
'更新中ウィンドウの表示
UserForm1.Show vbModeless
UserForm1.Repaint
'リストを更新に適した状態に整える
Dim sn As String
sn = "リスト"
On Error Resume Next
Worksheets(sn).ShowAllData
On Error GoTo 0
Worksheets(sn).ListObjects("リスト1").ShowTotals = False
Dubug.Print Worksheets(sn).Range("A1").CurrentRegion.Address ←ここに追加
Worksheets(sn).Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
'データを取得するファイルのファイル名を取得
Dim Shell As Object, Folder As Object, Target As String, cnt As Long
Set Shell = CreateObject("Shell.Application")
Set Folder = Shell.Namespace(ThisWorkbook.Path)
Target = Dir(ThisWorkbook.Path & "\室内報告??-???.doc*") '130426_付属資料は除く
'データの取得を開始する行を決める
cnt = Range("A65535").End(xlUp).Row
For i = 1 To cnt '未のレコードを削除
If Cells(i, 8).Value = "未" Then
Range(i & ":" & i).Delete
i = i - 1
End If
Next i
cnt = Range("A65535").End(xlUp).Row
'データの取得
Do While Target <> ""
' On Error Resume Next
If Worksheets(sn).Range("A1").EntireColumn.Find(Target) Is Nothing Then
cnt = cnt + 1
Worksheets(sn).Hyperlinks.Add Anchor:=Cells(cnt, 1), Address:=ThisWorkbook.Path & "\" & Target, TextToDisplay:=Target
Cells(cnt, 2) = Left(Folder.GetDetailsOf(Folder.ParseName(Target), 24), 10) '報告日
Cells(cnt, 3) = Folder.GetDetailsOf(Folder.ParseName(Target), 20) '作成者
Cells(cnt, 3) = Application.WorksheetFunction.Substitute(Trim(Cells(cnt, 3)), " ", " ")
Cells(cnt, 4) = Folder.GetDetailsOf(Folder.ParseName(Target), 21) '表題
Cells(cnt, 5) = Folder.GetDetailsOf(Folder.ParseName(Target), 23) 'チームユニット
Cells(cnt, 6) = Folder.GetDetailsOf(Folder.ParseName(Target), 22) '研究テーマ
Cells(cnt, 7) = Mid(Folder.GetDetailsOf(Folder.ParseName(Target), 24), 12, 200) '関連部署
Cells(cnt, 8) = Folder.GetDetailsOf(Folder.ParseName(Target), 18) '所属長チェック
End If
On Error GoTo 0
Target = Dir()
Loop
'そのままだと不都合な設定を元に戻す
Set Folder = Nothing
Set Shell = Nothing
'リストを見栄えよく整える
Worksheets(sn).ListObjects("リスト1").ShowTotals = True '集計行再表示
Worksheets(sn).Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
Range("J1").Value = Date & "_" & Time
'更新完了の表示
ThisWorkbook.Save
Unload UserForm1
MsgBox ("データベースおよび集計表の更新が完了しました")
UserForm2.Label2.Caption = Range("J1").Value
UserForm2.Show vbModeless
End Sub
ご教授通りでしょうか？
よろしくお願い致します。
（いぬまねき） 2022/08/15(月) 09:15
モジュールの先頭にOption Explicitを挿入してください。
（VBEのオプションを設定して、常に表示する設定にしておくとよいですよ。）
そうしておけば、そうしたミスは普通はコンパイルエラーになるはずです。
$A$1が返っていませんかね。
なお、
Worksheets(sn).Range("A1").CurrentRegion.Sort Key1:=Range("A1")...も
Worksheets(sn).Range("A1").CurrentRegion.Sort Key1:=Worksheets(sn).Range("A1")...
としておいたほうが安全確実ですよ。
類似のケースで失敗しないように、そういう癖をつけておくことを推奨します。
（γ） 2022/08/15(月) 10:15
> For i = 1 To cnt '未のレコードを削除
削除されると上に繰り上がるので下から
>i = i - 1
forのカウンタは、自分で勝手にいじらない （駄目） 2022/08/15(月) 10:25
ご教授ありがとうございます。
申し訳ありません。私のマクロ知識は薄々なので気づきません。
＞モジュールの先頭にOption Explicitを挿入してください。
意味と手法は分かりませんが、これはデバック技法の助言ですかね？
＞$A$1が返っていませんかね。
この意味すら分かりません。
後の記述は、安全確実な手法のようでこれは理解できました。
（いぬまねき） 2022/08/15(月) 11:28
ご教授ありがとうございます。
カウンタ関連のご指導、この部分が今回悪さしている根源なのですか？
申し訳ありませんが、もう少し具体的な改善法をご教授願えないでしょうか？
＞i = i - 1
これは、どこをこのように変更すれば良いのでしょうか。
（いぬまねき） 2022/08/15(月) 11:35
| ＞モジュールの先頭にOption Explicitを挿入してください。 | 意味と手法は分かりませんが、これはデバック技法の助言ですかね？ もちろんその積りですよ。なんだと思われましたか？
http://officetanaka.net/excel/vba/beginner/11.htm
http://officetanaka.net/excel/vba/beginner/06.htm
を参考にしてください。 VBAを使う際に、効率が上がるものですので、推奨されることが多いです。 それを挿入するとことで、他のエラー原因が判明することも可能性としてあるので、 それも提案した理由です。
| ＞$A$1が返っていませんかね。 | この意味すら分かりません。 少し早まりましたか。 出力したアドレスは $A$1 となりませんでしたか、というコメントです。 何度もやり取りするのが手間かと思って書きました。
そのケースであれば、エラーメッセージがあなたの書かれたものとピッタリなので、 そういうことではないかと想像して検証を提案しました。
もしそれがA1だけでなく矩形範囲であれば、私はこれ以上の持ち合わせ（想定）はありません。 こちらの提案に不信感をお持ちのようなので、私はここまでです。
（γ） 2022/08/15(月) 11:43
（´・ω・`） 2022/08/10(水) 14:37 の
>最近、下記エラーが発生して困っています 最近、なにか運用を変えたのでは？
という質問について回答が無いようですが、
データが変わったとかシートのレイアウトを変えたとか、何か心当たりはありませんか？
コードはコマンドボタンを押した時のものですが、その前にはどのような処理をされているかも説明するといいかもです。
ボタンを押す前の処理(手作業も含めて)で何か変更していないですか？
また、コードについては示されていますが、シートのデータについては説明がありません。
シートのレイアウト(行・列がわかる形で)とデータ内容を提示されるのが近道では無いでしょうか。
(もちろんデータ内容は公開するのに支障が無い内容に変更して)
（めいぷる） 2022/08/15(月) 12:02
■１
＞マクロの勉強は、難しそうですが頑張ります。
頑張ってください。わかってしまえばそんなに難しいことはしてないと思います。
VBAを学ぶ上で参考になりそうなテクニックを紹介しておきます。
【ステップ実行】
https://www.239-programing.com/excel-vba/basic/basic023.html
http://plus1excel.web.fc2.com/learning/l301/t405.html
【ブレークポイント】 https://www.239-programing.com/excel-vba/basic/basic022.html https://www.tipsfound.com/vba/01010
【イミディエイトウィンドウ】 https://www.239-programing.com/excel-vba/basic/basic024.html https://excel-ubara.com/excelvba1/EXCELVBA486.html
【ローカルウィンドウ】 https://excel-ubara.com/excelvba4/EXCEL266.html http://excelvba.pc-users.net/fol8/8_2.html
■２
提示されたコードが見ずらいので少し手を入れてみました。
Private Sub CommandButton1_Click()
Dim Folder As Object
Dim i As Long, cnt As Long, Target As String
UserForm2.Hide
'更新中ウィンドウの表示
UserForm1.Show vbModeless
UserForm1.Repaint
'リストを更新に適した状態に整える
With Worksheets("リスト")
On Error Resume Next
.ShowAllData
On Error GoTo 0
.ListObjects("リスト1").ShowTotals = False
.Range("A1").CurrentRegion.Sort _
Key1:=.Range("A1"), _
Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, _
DataOption1:=xlSortNormal
Set Folder = CreateObject("Shell.Application").Namespace(ThisWorkbook.Path)
Target = Dir(ThisWorkbook.Path & "\室内報告??-???.doc*") '130426_付属資料は除く
'▼後ろ（下）から上に見るように変更
For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 1 Step -1
.Cells(i, "H").Value = "未"
.Rows(i).Delete
Next
Do While Target <> ""
If .Range("A:A").Find(Target) Is Nothing Then
cnt = .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row
.Hyperlinks.Add Anchor:=.Cells(cnt, "A"), Address:=ThisWorkbook.Path & "\" & Target, TextToDisplay:=Target
.Cells(cnt, 2) = Left(Folder.GetDetailsOf(Folder.ParseName(Target), 24), 10) '報告日
.Cells(cnt, 3) = Folder.GetDetailsOf(Folder.ParseName(Target), 20) '作成者
.Cells(cnt, 3) = Application.WorksheetFunction.Substitute(Trim(Cells(cnt, 3)), " ", " ")
.Cells(cnt, 4) = Folder.GetDetailsOf(Folder.ParseName(Target), 21) '表題
.Cells(cnt, 5) = Folder.GetDetailsOf(Folder.ParseName(Target), 23) 'チームユニット
.Cells(cnt, 6) = Folder.GetDetailsOf(Folder.ParseName(Target), 22) '研究テーマ
.Cells(cnt, 7) = Mid(Folder.GetDetailsOf(Folder.ParseName(Target), 24), 12, 200) '関連部署
.Cells(cnt, 8) = Folder.GetDetailsOf(Folder.ParseName(Target), 18) '所属長チェック
End If
Target = Dir()
Loop
.Range("A1").CurrentRegion.Sort _
Key1:=.Range("A1"), _
Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, _
DataOption1:=xlSortNormal
.Range("J1").Value = Now
'更新完了の表示
ThisWorkbook.Save
Unload UserForm1
MsgBox ("データベースおよび集計表の更新が完了しました")
UserForm2.Label2.Caption = .Range("J1").Value
UserForm2.Show vbModeless
End With
End Sub
どのモジュールに書いているかは分かりませんが、対象のシートをきちんと指定するようにしたほうがよいとおもいます。
（もこな２） 2022/08/15(月) 12:15
あと、本エクセルの学校の投稿方法も誤っていて、コメント記入したあと、ニックネームを変えてデーター更新を押すと、コメントが投稿されないことが2度あり、これも私のミスでした。
前置きが長くなりました。
（´・ω・`） 2022/08/10(水) 14:37 の
>最近、下記エラーが発生して困っています 最近、なにか運用を変えたのでは？ ご指摘の通り運用者の誰かが何かを無意識に変えたか意識的に変えたのだと思います。 当たり前ですが、アラームが出る前までは正常に運用されていたと聞いています。
今後は、
１．Y様ご教授内容を理解することと頂いた参考資料を勉強致します。
２．めいぷる様ご指摘の件、私に依頼して来た者からは何も聞いておらず、ただただ、いつも使っているエクセルにアラームが出て使えないので見てほしい。と言われただけなのです。重ねて申しますが、私もこのエクセルシートは知らないので何をどう使っているのかも知らないのです。エクセルの学校でお聞きするのが早いのかな。と思った次第です。
あと、機密性が高いので内容を変更して皆さまにご提示するにも時間がかかる状況です。
ただ、確かにご指摘の通り、シート全体の構成などご提示の上質問するほうが近道だと思います。
ちょっとお時間を頂きたく思います。
３．もなこ２様、ありがとうございます。ご提示のコード、再度じっくり見て理解致します。
さらにご指摘の、どのモジュール、対象シートをきちんと指定との助言ご最もです。
長くなりますし、もしかすると、この投稿は（複数の先生方のご教授を一括返答）ルール違反かもしれませんので、改めて回答致します。
申し訳ありません。
（いぬまねき） 2022/08/15(月) 15:22
Yさんじゃないよ、γさんだよ。
↓の()の中をそれぞれ一文字づつクリップボードにコピして WEBブラウザで検索してみてください。 （γ） （Y） （通りすがり） 2022/08/15(月) 16:08
>Yさんじゃないよ、γさんだよ。 IE 以外は小文字の「Y」に変換されますね。 ただ指摘があるようにコピーして貼り付けてみると「γ」です。 変換というよりも「γ」に表示できないということなのかな? （ 閲覧者） 2022/08/15(月) 19:15
>フォントが違うだけ。 小文字のガンマですよ。 （ 閲覧者） 2022/08/15(月) 21:10
本筋とは関係ありませんので恐縮ですが、 Windows10での話になってしまいますけど、 Webページを表示する際の標準フォントの初期設定は、 IEはMS PGothicで、 EdgeはMeiryo、 Chromeはメイリオ。 この掲示板で行頭に半角スペースを入れると、 等幅フォント（固定幅フォント）が採用され、 それは各ブラウザ共、MS Gothicになっています。
Meiryoとメイリオのγ(ガンマ)は、γの下端が（ ）の下端より下がって表示され、 Y(ワイ)との区別はつけられているように見えます。 IEの標準フォントをMeiryo UIに変更すると、 IEでもEdgeやChromeと同じように表示されます。 （傍観者） 2022/08/15(月) 21:24
私もYに見えますね。Yさんで差し支えないでしょう。
質問者にいちいち指摘するようなことじゃない。
（半平太） 2022/08/15(月) 21:35
↓この3行に差し替えてみてください。位置はそのままでOKです。
msgbox Worksheets(sn).Range("A1").CurrentRegion.Address ←ここに追加
msgbox Worksheets(sn).ListObjects("リスト1").Range.Address
msgbox WorksheetFunction.Counta(Worksheets(sn).Columns("I"))
（マナ） 2022/08/15(月) 22:17
γさまだったんですね。 重ね重ね、もうしわけありませんでした。
通りすがりさま、閲覧者さま、傍観者さま、半平太さま、
ご指摘、ご指導、ありがとうございました。
諸事情により、ご連絡が遅れました。
マナさま、
ご指導ありがとうございます。
トライしてみます。
（いぬまねき） 2022/08/18(木) 12:34
試してみました。
クリックごとにメッセージボックスが出て、当初と同様のアラームメッセージが出ました。
エラー：実行エラー 1004
RangeクラスのSortメゾットが失敗しました。
以下に、コードを示します。
Private Sub CommandButton1_Click()
UserForm2.Hide
'更新中ウィンドウの表示
UserForm1.Show vbModeless
UserForm1.Repaint
'リストを更新に適した状態に整える
Dim sn As String
sn = "リスト"
On Error Resume Next
Worksheets(sn).ShowAllData
On Error GoTo 0
Worksheets(sn).ListObjects("リスト1").ShowTotals = False
MsgBox Worksheets(sn).Range("A1").CurrentRegion.Address ←追加しました
MsgBox Worksheets(sn).ListObjects("リスト1").Range.Address ←追加しました。
MsgBox WorksheetFunction.CountA(Worksheets(sn).Columns("I")) ←追加しました。これより下3行の構文が黄色網掛けとなりました。
Worksheets(sn).Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
'データを取得するファイルのファイル名を取得
Dim Shell As Object, Folder As Object, Target As String, cnt As Long
Set Shell = CreateObject("Shell.Application")
Set Folder = Shell.Namespace(ThisWorkbook.Path)
Target = Dir(ThisWorkbook.Path & "\室内報告??-???.doc*") '130426_付属資料は除く
'データの取得を開始する行を決める
cnt = Range("A65535").End(xlUp).Row
For i = 1 To cnt '未のレコードを削除
If Cells(i, 8).Value = "未" Then
Range(i & ":" & i).Delete
i = i - 1
End If
Next i
cnt = Range("A65535").End(xlUp).Row
'データの取得
Do While Target <> ""
' On Error Resume Next
If Worksheets(sn).Range("A1").EntireColumn.Find(Target) Is Nothing Then
cnt = cnt + 1
Worksheets(sn).Hyperlinks.Add Anchor:=Cells(cnt, 1), Address:=ThisWorkbook.Path & "\" & Target, TextToDisplay:=Target
Cells(cnt, 2) = Left(Folder.GetDetailsOf(Folder.ParseName(Target), 24), 10) '報告日
Cells(cnt, 3) = Folder.GetDetailsOf(Folder.ParseName(Target), 20) '作成者
Cells(cnt, 3) = Application.WorksheetFunction.Substitute(Trim(Cells(cnt, 3)), " ", " ")
Cells(cnt, 4) = Folder.GetDetailsOf(Folder.ParseName(Target), 21) '表題
Cells(cnt, 5) = Folder.GetDetailsOf(Folder.ParseName(Target), 23) 'チームユニット
Cells(cnt, 6) = Folder.GetDetailsOf(Folder.ParseName(Target), 22) '研究テーマ
Cells(cnt, 7) = Mid(Folder.GetDetailsOf(Folder.ParseName(Target), 24), 12, 200) '関連部署
Cells(cnt, 8) = Folder.GetDetailsOf(Folder.ParseName(Target), 18) '所属長チェック
End If
On Error GoTo 0
Target = Dir()
Loop
'そのままだと不都合な設定を元に戻す
Set Folder = Nothing
Set Shell = Nothing
'リストを見栄えよく整える
Worksheets(sn).ListObjects("リスト1").ShowTotals = True '集計行再表示
Worksheets(sn).Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
Range("J1").Value = Date & "_" & Time
'更新完了の表示
ThisWorkbook.Save
Unload UserForm1
MsgBox ("データベースおよび集計表の更新が完了しました")
UserForm2.Label2.Caption = Range("J1").Value
UserForm2.Show vbModeless
End Sub
（いぬまねき） 2022/08/18(木) 12:59
そのメッセージを教えてください。
（マナ） 2022/08/18(木) 13:07
ご連絡ありがとうございます。
クリック毎に出てくる最初のメッセージは
$A$1:$H$836
次のメッセージは
$A$1:$H$677
次のメッセージは
0
です。
これでよろしいでしょうか？
（いぬまねき） 2022/08/18(木) 14:42
マナさんはこれを想定してたんですね なるほど、エラーになります。勉強になりました。 テーブルとテーブル外のデータはいっしょにソートできないんですね （´・ω・`） 2022/08/18(木) 15:01
対応策はソートの前に
With ActiveSheet.ListObjects("リスト1")
.Resize .Range.CurrentRegion
End With
（´・ω・`） 2022/08/18(木) 15:08
ありがとうございます。
何だか雲の上の会話を拝聴しているようです。
ご指導のコードをマナ先生ご指導の3行の前に挿入したところ、
コンパイルエラー
引数は省略できません。
と出ました。
恥ずかしながら、Rangeの後に("A1")と入れてみたところ、
コンパイルエラー
プロパティの使い方が不正です。
と出ました。
（いぬまねき） 2022/08/18(木) 15:38
With Worksheets(sn).ListObjects("リスト1")
.Resize .Range.CurrentRegion
End Wit
ですね。
私のミスなので申し訳ないですが、でも、これくらいは自分で直してほしいところです
（´・ω・`） 2022/08/18(木) 15:45
お恥ずかしいです。
マクロ初心者レベルです。
ご指導のコードを挿入したところ、
MsgBox ("データベースおよび集計表の更新が完了しました")
まで行きました。（マナさまご教授の3行を削除してもうまくいきます）。
修復できたかと思ったのですが、メッセージボックスをOKすると再度、UserForm2が働き出し、
繰り返すようになってしまいました。
End Sub は記述があるのになぜですか？
以下、コードを示します。
Private Sub CommandButton1_Click()
UserForm2.Hide
'更新中ウィンドウの表示
UserForm1.Show vbModeless
UserForm1.Repaint
'リストを更新に適した状態に整える
Dim sn As String
sn = "リスト"
On Error Resume Next
Worksheets(sn).ShowAllData
On Error GoTo 0
Worksheets(sn).ListObjects("リスト1").ShowTotals = False
With Worksheets(sn).ListObjects("リスト1")
.Resize .Range.CurrentRegion
End With ←勝手に「h」を追加しました。
Worksheets(sn).Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
'データを取得するファイルのファイル名を取得
Dim Shell As Object, Folder As Object, Target As String, cnt As Long
Set Shell = CreateObject("Shell.Application")
Set Folder = Shell.Namespace(ThisWorkbook.Path)
Target = Dir(ThisWorkbook.Path & "\室内報告??-???.doc*") '130426_付属資料は除く
'データの取得を開始する行を決める
cnt = Range("A65535").End(xlUp).Row
For i = 1 To cnt '未のレコードを削除
If Cells(i, 8).Value = "未" Then
Range(i & ":" & i).Delete
i = i - 1
End If
Next i
cnt = Range("A65535").End(xlUp).Row
'データの取得
Do While Target <> ""
' On Error Resume Next
If Worksheets(sn).Range("A1").EntireColumn.Find(Target) Is Nothing Then
cnt = cnt + 1
Worksheets(sn).Hyperlinks.Add Anchor:=Cells(cnt, 1), Address:=ThisWorkbook.Path & "\" & Target, TextToDisplay:=Target
Cells(cnt, 2) = Left(Folder.GetDetailsOf(Folder.ParseName(Target), 24), 10) '報告日
Cells(cnt, 3) = Folder.GetDetailsOf(Folder.ParseName(Target), 20) '作成者
Cells(cnt, 3) = Application.WorksheetFunction.Substitute(Trim(Cells(cnt, 3)), " ", " ")
Cells(cnt, 4) = Folder.GetDetailsOf(Folder.ParseName(Target), 21) '表題
Cells(cnt, 5) = Folder.GetDetailsOf(Folder.ParseName(Target), 23) 'チームユニット
Cells(cnt, 6) = Folder.GetDetailsOf(Folder.ParseName(Target), 22) '研究テーマ
Cells(cnt, 7) = Mid(Folder.GetDetailsOf(Folder.ParseName(Target), 24), 12, 200) '関連部署
Cells(cnt, 8) = Folder.GetDetailsOf(Folder.ParseName(Target), 18) '所属長チェック
End If
On Error GoTo 0
Target = Dir()
Loop
'そのままだと不都合な設定を元に戻す
Set Folder = Nothing
Set Shell = Nothing
'リストを見栄えよく整える
Worksheets(sn).ListObjects("リスト1").ShowTotals = True '集計行再表示
Worksheets(sn).Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
Range("J1").Value = Date & "_" & Time
'更新完了の表示
ThisWorkbook.Save
Unload UserForm1
MsgBox ("データベースおよび集計表の更新が完了しました")
UserForm2.Label2.Caption = Range("J1").Value
UserForm2.Show vbModeless
End Sub
Private Sub Label2_Click()
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
End If
End Sub
（いぬまねき） 2022/08/18(木) 16:16
UserFormを閉じる命令が見当たりませんが。 UserForm 閉じる で検索してみたらいかがでしょう。
個人的な見解は、自身でコードを理解(読む)する気が無いのなら、 コードを触らない方がいいです。 今上手くいったとしても、ちょっとした変更でゴミに変わってしまいますから。
その気があるのなら、ネット上に情報はゴロゴロ転がっていますので、 切り貼りではなく、各々のコードは何をやっているか、調べてみては。 （tkit） 2022/08/18(木) 16:44
ご助言、ありがとうございます。
UserFormを閉じる命令がありませんか？
元々は、正常に動作していたと聞いているのですが？
今後は、自分で解決します。
ありがとうございました。
（いぬまねき） 2022/08/18(木) 16:54
＞ UserFormを閉じる命令が見当たりませんが。 失礼、UserForm1を閉じて、UserForm2を開いているコードになっています。 （tkit） 2022/08/18(木) 17:04
この CommandButton1_Click はどこにあるんですか？ 実は UserForm2 上にあったりしませんか？
クリックすると、 自分自身を隠して→いろいろやって→自分を再表示 するマクロなのでは？ これが正しい動作なのでは？
回答者はあなたの画面は見えてないのですから、 ちゃんと説明しないと分かりません。状況が分からない中では回答もできませ （´・ω・`） 2022/08/18(木) 17:16
ご指導ありがとうございます。
MsgBox ("データベースおよび集計表の更新が完了しました")
の後のend sub の前に、
unload userform2
を挿入したところ、完了まで漕ぎつきました。
解決できました。
ありがとうございます。
（いぬまねき） 2022/08/19(金) 16:26
ご指導、ありがとうございます。
＞この CommandButton1_Click はどこにあるんですか？
ご指摘の通り、 UserForm2 上に張り付けてあります。
＞クリックすると、
＞ 自分自身を隠して→いろいろやって→自分を再表示 するマクロなのでは？
＞ これが正しい動作なのでは？
ハッキリ言って、正確な動きはよくわかりません。
＞回答者はあなたの画面は見えてないのですから、
＞ちゃんと説明しないと分かりません。状況が分からない中では回答もできません。
ご最もだと思います。全貌を提示もせず解決しませんよね。
よく見てみるとデーターが記載されているSheetにもマクロが記載されていて、
そこにも CommandButton1_Clickの記載がありました。
userform2のコードと殆ど同じ処理ですが、１つのコマンドボタンで二か所の処理をしていました。
シートモジュールのコードは、以下の通りです。
Private Sub CommandButton1_Click()
'更新中ウィンドウの表示
UserForm1.Show vbModeless
UserForm1.Repaint
'リストを更新に適した状態に整える
Dim sn As String
sn = "リスト"
On Error Resume Next
Worksheets(sn).ShowAllData
On Error GoTo 0
' Worksheets(sn).Range("B3").CurrentRegion.Sort Key1:=Range("B3"), Order1:=xlAscending
Worksheets(sn).ListObjects("リスト1").ShowTotals = False
Worksheets(sn).Range("B3").CurrentRegion.Sort Key1:=Range("B3"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
'データを取得するファイルのファイル名を取得
Dim Shell As Object, Folder As Object, Target As String, cnt As Long
Set Shell = CreateObject("Shell.Application")
Set Folder = Shell.Namespace(ThisWorkbook.Path)
Target = Dir(ThisWorkbook.Path & "\室内報告??-???.doc") '130426_付属資料は除く
' Target = Dir(ThisWorkbook.Path & "\室内報告*.doc")
'データの取得を開始する行を決める
cnt = Range("B65535").End(xlUp).Row
For i = 4 To cnt '未のレコードを削除
If Cells(i, 9).Value = "未" Then
Range(i & ":" & i).Delete
i = i - 1
End If
Next i
' Dim saikagyo As Integer
' saikagyo = Range("B65535").End(xlUp).Row
cnt = Range("B65535").End(xlUp).Row
'データの取得
Do While Target <> ""
On Error Resume Next
If Worksheets(sn).Range("B1").EntireColumn.Find(Target) Is Nothing Then
' If Mid(Target, 5, 2) * 1000 + Mid(Target, 8, 3) > _
' Mid(Cells(saikagyo, 2), 5, 2) * 1000 + Mid(Cells(saikagyo, 2), 8, 3) Then
' For i = 1 To 300
' Cells(cnt, i) = Folder.GetDetailsOf(Folder.ParseName(Target), i)
' Next 'プロパティの確認
cnt = cnt + 1
Hyperlinks.Add Anchor:=Cells(cnt, 2), Address:=ThisWorkbook.Path & "\" & Target, TextToDisplay:=Target
Cells(cnt, 3) = Left(Folder.GetDetailsOf(Folder.ParseName(Target), 24), 10) '報告日
Cells(cnt, 4) = Folder.GetDetailsOf(Folder.ParseName(Target), 20) '作成者
Cells(cnt, 4) = Application.WorksheetFunction.Substitute(Trim(Cells(cnt, 4)), " ", " ")
Cells(cnt, 5) = Folder.GetDetailsOf(Folder.ParseName(Target), 21) '表題
Cells(cnt, 6) = Folder.GetDetailsOf(Folder.ParseName(Target), 23) 'チームユニット
Cells(cnt, 7) = Folder.GetDetailsOf(Folder.ParseName(Target), 22) '研究テーマ
Cells(cnt, 8) = Mid(Folder.GetDetailsOf(Folder.ParseName(Target), 24), 12, 200) '関連部署
Cells(cnt, 9) = Folder.GetDetailsOf(Folder.ParseName(Target), 18) '所属長チェック
End If
On Error GoTo 0
Target = Dir()
Loop
'そのままだと不都合な設定を元に戻す
Set Folder = Nothing
Set Shell = Nothing
'リストを見栄えよく整える
Worksheets(sn).ListObjects("リスト1").ShowTotals = True '集計行再表示
Worksheets(sn).Range("B3").CurrentRegion.Sort Key1:=Range("B3"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal
'Worksheets(sn).Range("B3").CurrentRegion.Sort Key1:=Range("B3"), Order1:=xlAscending 'ファイル名を昇順で並べ替え
Worksheets("集計").PivotTables("ﾋﾟﾎﾞｯﾄﾃｰﾌﾞﾙ1").PivotCache.Refresh
Range("L2").Value = Date & "_" & Time
'更新完了の表示
ThisWorkbook.Save
Unload UserForm1
MsgBox ("データベースおよび集計表の更新が完了しました")
End Sub
UserForm2.Show vbModeless
UserForm2.Label2.Caption = Range("J1").Value
End Sub
UserForm2.Hide
End Sub
でも、一応、解決できています。
tkitさま、ご指摘の通り、新たな問題が発生てもわからないのでは困るので、頑張って勉強します。
（いぬまねき） 2022/08/19(金) 16:47
投稿先を間違えたので削除 （マナ） 2022/08/21(日) 12:25
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.