VBAの処理が止まる原因と対策を知りたい

このQ&Aのポイント
  • VBAの処理が途中でフリーズする原因と対策を教えてください。
  • 関数Aと関数BでVBAの処理がフリーズする問題が発生しています。CPU使用率も固定されています。解決策を教えてください。
  • 現在VBAを使用してサーバ上のブックを開いたり、文字列の検索などの処理を行っていますが、途中で処理が止まってしまいます。原因と対策を教えてください。
回答を見る
  • ベストアンサー

VBAの処理が止まる原因と対策を知りたい

現在以下のとおりのVBAを動かしいますが、途中でフリーズしてしまうため、 原因が特定できずに困っています。 その原因と対策もしくは、原因を突き止める方法をご教授いただければと思います。 ・サーバ上にあるブックを4つ開く(BookA、BookB、BookC、BookD) ・BookAに記載している文字列を配列に入れる ・BookB上にて、前述の文字列を検索し、そのアドレスを取得(後述の関数B) ・BookB上にて、前述のアドレスから別の文字列を取得(後述の関数A) となります。なお「Application.ScreenUpdatingの停止」と「Application.Calculationを手動」は実施しましたが、改善しませんでした。 以下環境、状況、VBAの記述になります。 環境 OS:Windows7 64bit CPU:i3 メモリ:8GB EXCEL:2010 状況 ・関数Aから関数Bを呼んだ後にフリーズしている模様です(関数Bを呼ぶところまでは、確認できますが、その後フリーズをするため、関数Aに戻っているかは不明です)。 ・フリーズ時のEXCEL.EXEのCPU使用率は25%で固定です。 関数A Function Test1(WS1 As Worksheet, Str1() As String, Str2() As String) Dim i As Integer Dim Row As Integer, Co As Integer Dim Temp_Range As Range Dim Temp_Str As String For i = 1 To UBound(Str2) ReDim Preserve Str1(i) Temp_Str = Test2(WS1, Str2(i - 1)) If Temp_Str <> "ない" And Temp_Str <> "重複" Then Set Temp_Range = WS1.Range(Temp_Str) If Temp_Range.MergeCells Then Co = Temp_Range.Column + Temp_Range.MergeArea.Count - 1 Else Co = Temp_Range.Column End If   Row = Temp_Range.Row Str1(i - 1) = WS1.Cells(Row, Co).Offset(0, 1).Value End If Next i End Function 関数B Function Test2(WS1 As Worksheet, Str1 As String) As String Dim temp As Range Dim a, b As Boolean Dim r As String Dim i, j As Integer Set temp = WS1.UsedRange For i = 1 To temp.Rows(temp.Rows.Count).Row For j = 1 To temp.Columns(temp.Columns.Count).Column If Replace(WS1.Cells(i, j).Value, vbLf, "") = Replace(Str1, vbLf, "") Then If a = False Then r = WS1.Cells(i, j).Address a = True Else r = "重複" b = True Exit For End If End If Next If b = True Then Exit For Next If r = "" Then r = "ない" Test2 = r End Function

質問者が選んだベストアンサー

  • ベストアンサー
  • notnot
  • ベストアンサー率47% (4847/10260)
回答No.2

>原因を突き止める方法をご教授いただければと思います。 ステップごとに実行してみてください。 わからなければ、「VBA ステップ実行」で検索してください。

kinu_tofu_momen
質問者

お礼

ご回答いただきありがとうございます。 ステップ毎に実行し問題となる行を特定したいと思います。

その他の回答 (1)

  • drum_KT
  • ベストアンサー率43% (1108/2554)
回答No.1

String型の変数の扱い方がおかしいです。  Str1() As String  Str1(i) こんな記法はないはずです。

kinu_tofu_momen
質問者

補足

Test1関数の呼び出し元でstring型の配列を宣言し(Dim st() as String)、 それをTest1の引数(call Test1(WS1,st) )として参照渡した上で、 Test1関数内で動的に配列数を増やすことを想定しています。 この様な記述はしないものなのでしょうか。

関連するQ&A

  • vbaの繰り返し処理について

    vbaです。 Sub Test1() Dim Str As String Dim Pnt1 As Long Dim Pnt2 As Long Str = Range("A1") Pnt1 = InStr(Str, "重 http://") If Pnt1 <= 0 Then Exit Sub Pnt2 = InStr(Pnt1, Str, "要") If Pnt2 <= 0 Then Range("B1") = Mid(Str, Pnt1 + 2) Else Range("B1") = Mid(Str, Pnt1 + 2, Pnt2 - (Pnt1 + 2)) End If End Sub という式でA1からA2.A3と下にURLが入っており空欄になるまで同じ処理をしたいのですがどのように変更すれば作動しますでしょうか?

  • VBA 処理の途中でエラーが出る

    VBA初心者です。 シート1とシート2があり、 シート1の表の列Mと列Nにそれぞれシート2のデータを参照する COUNTIFS関数を入れたいと思い、以下のように作成しました。 ※シート1は場合よって行の最後行が違います。 Dim Test As String Dim Test2 As String Dim i As Long For i = 1 To Cells(Rows.Count,1).End(xlUP).Row Test=Range("A" & i ) If MyStr<>""Then Range("M" & i) ="=COUNTIFS(Sheet2!,A:A"& Test &",Sheet2!B:B,M1"&")" End If Test2=Range("A" & i ) If MyStr<>""Then Range("N" & i )="=COUNTIFS(Sheet2!,A:A"& Test2 &",Sheet2!B:B,N1"&")" End If Next i この内容にて、処理が成功していたのですが、 急に、行150のあたりで処理が止まり、実行時エラー(アプリケーション定義またはオブジェクト定義のエラーです) が出るようになりました。 行150より上の方は、列Mと列N共にCOUNTIFS関数が入っています。 この場合、どのようにすればよろしいのでしょうか? エラーの対処、または別の記述方法があれば、ご教授頂きたく存じます。

  • VBAの処理を軽くしたい

    各行ごとに5回セルを参照した結果を吐き出すプログラムを作成しています。 200行前後の処理が必要なのですが、現在のコードではあまりにも処理が重くなっています。 とにかく処理を軽くしたいのですが、どのような方法が考えられるでしょうか? 初心者なのでコードも含めてご教示頂けたら幸いです。 Sub test(b, c, d) Dim i1, i2 As Long Dim A1 As String  For i1=0 To Cells(Rows.Count, 1).End(xlUp).Row For i2 = 0 To 5 If Range(b).offset(i1, i2).Value = "x1" Or Range(c).offset(i1, i2).Value = "x1" Then A1 = "XXX" ElseIf Range(b).offset(i1, i2).Value = Range(c).offset(i1, i2).Value Then A1 = "YYY" Else A1 = "ZZZ" End If Range(d).offset(i1, i2).Value = A1 Next i2 Next i1 End Sub

  • VBAエラー

    下のもので、 rangeクラスのselectメソッドが失敗しました がでてしまいます。 ★★★のところで止まってしまいます。 1つ目のエクセルで、ファイル名を入力、検索して開き、8行目でオートフィルタをするマクロです。 オートフィルタのところで止まります。 どこが悪いのか、ご教授いただけませんでしょうか。 よろしくお願い致します。 Sub ファイルを開く()  Dim str As String   Dim nCnt As Integer  Dim sHozon As String  Dim sFilename As String Dim Grp As String If Range("B2").Value <> "バーコード読み取り" Then '保存場所を指定 sHozon = "※※※" Grp = Right(Range("B2"), Len(Range("B2")) - InStr(Range("B2"), "F")) 'ファイル名を設定 sFilename = "AA" & Left(Range("B2"), 10) & ".xls" 'ファイルが存在しているか確認 str = sHozon & "\" & sFilename str = Dir(str) If (str <> sFilename) Then 'ファイルが存在しない場合、エラー MsgBox ("ファイルが存在しません") Else 'ファイルを開く Range("B2").Select Workbooks.Open sHozon & "\" & sFilename End If End If Workbooks(sFilename).Activate Sheets("B").Select ActiveSheet.Unprotect Workbooks(sFilename).Activate Rows("8:8").Select   ★★★ Selection.AutoFilter ActiveSheet.Range("$A$8:$BL$1008").AutoFilter Field:=58, Criteria1:=Grp

  • 小数点以下表示

    averageで計算した値を表示したところ、 勝手に四捨五入されてしまいました 小数点第二位まで表示したいので どなたかよろしくお願いいたします<m(__)m> Option Explicit Public Sub 平均() Const SH_NAME As String = "VBA" Dim art As String Dim i Dim ws As Worksheet Dim endrow As Long Dim msg As String Dim writerow As Integer Dim target As Range Dim ActCell As Variant Dim Result As Integer Set ws = ThisWorkbook.Worksheets(SH_NAME) writerow = 2 art = InputBox("日付を入力してください") With ws endrow = .Cells(Rows.Count, 2).End(xlUp).Row For i = 2 To endrow If art = .Range("A" & i) Then If target Is Nothing Then Set target = Range("D" & i) Else Set target = Union(target, Range("D" & i)) End If Else If InStr(msg, .Range("A" & i)) = 0 Then msg = msg & .Range("A" & i) & vbCrLf End If End If Next i If msg <> "" Then MsgBox msg End If target.Select ActCell = Selection.Address Result = Application.WorksheetFunction.Average(.Range(ActCell)) Range("F39").Value = Result Range("F39").NumberFormatLocal = "0.00" End With End Sub

  • VBAで複数列からの条件指定でデータを抽出したい

    講習会の受講者名簿を作成しています。(名簿は科目別で3つのシートに分かれています。) 現在下記モジュールで、受講者名・受講者番号を個々に入力し検索出来るようにしていますが、 受講日(例:2014/4/1~2014/4/31の間)で受講者を抽出できるようにしたいと考えています。 しかし、受講予定日は過去のものも含め複数列(I列~N列)まであり、受講者によって受講日の入力されている列がI列~N列間でまちまちです。 このような場合、どのようにVBAを変更したら受講日で検索が可能になるでしょうか? 宜しくお願いします。 Sub Sample2() Dim k As Long, endRow As Long, wS As Worksheet Set wS = Worksheets("検索&抽出") If wS.Range("B1") = "" And wS.Range("B2") = "" Then MsgBox "検索データを入力してください" Exit Sub End If endRow = wS.Cells(Rows.Count, "A").End(xlUp).Row If endRow > 4 Then wS.Rows(5 & ":" & endRow).ClearContents End If For k = 2 To 4 With Worksheets(k) If wS.Range("B1") <> "" Then .Range("A1").AutoFilter field:=2, Criteria1:=wS.Range("B1") End If If wS.Range("B2") <> "" Then .Range("A2").AutoFilter field:=3, Criteria1:=wS.Range("B2") End If If .AutoFilter.FilterMode Then endRow = .Cells(Rows.Count, "A").End(xlUp).Row If endRow > 2 Then Range(.Cells(3, "A"), .Cells(endRow, "N")).Copy wS.Cells(Rows.Count, "A").End(xlUp).Offset(1) End If .AutoFilterMode = False End If End With Next k End Sub

  • オブジェクト??

    またまた困っております inputboxで入力した日付を検索して複数選択しようとしたのですが unionの使い方がよくわかりません(・・;) どこが間違っているのかもしくは何が足りないのか教えてください<m(__)m> どうかよろしくお願いします! Option Explicit Sub グラフ() Const SH_NAME As String = "VBA" Dim art As String Dim i Dim ws As Worksheet Dim endrow As Long Dim msg As String Dim writerow As Integer Dim grahu As Chart Dim target As Range Set ws = ThisWorkbook.Worksheets(SH_NAME) writerow = 2 art = InputBox("日付を入力してください") With ws endrow = .Cells(Rows.Count, 2).End(xlUp).Row For i = 2 To endrow If art = .Range("A" & i) Then Set target = Union(target, "D" & i) Else If InStr(msg, .Range("A" & i)) = 0 Then msg = msg & .Range("A" & i) & vbCrLf End If End If Next i target.Select End With If msg <> "" Then MsgBox msg End If MsgBox "グラフベースを作成しました" End Sub Set target = Union(target, "D" & i) ↑ここでエラーが起きて 「オブジェクトが必要です」と言われました どうすればよいのでしょうか?

  • VBA 検索するSheetの位置の変更

    現在、グループの数だけユーザー名の合計数をSheet2に抽出するという 事をやっているのですが....... コードの方は下記になります Sub Sample3() Dim i As Long, j As Long, k As Long, lastRow As Long, lastCol As Long Dim wS2 As Worksheet, wS3 As Worksheet Set wS2 = Worksheets("Sheet1") Set wS3 = Worksheets("Sheet2") Application.ScreenUpdating = False If wS2.Range("Y1") = "" Then wS2.Range("Y1") = "ダミー" End If With Worksheets("Sheet1") If .Range("A4") = "" Then .Range("A4") = "ダミー" End If lastRow = .Cells(Rows.Count, "B").End(xlUp).Row Range(.Cells(5, "B"), .Cells(lastRow, "B")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★ For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row wS2.Cells(7, (i - 2) * 8 + 3) = wS3.Cells(i, "A") .Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A") Range(.Cells(5, "AA"), .Cells(lastRow, "AA")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(7, (i - 2) * 8 + 2) For k = wS2.Cells(Rows.Count, (i - 2) * 8 + 2).End(xlUp).Row To 7 Step -1 wS2.Cells(k, (i - 2) * 8 + 3) = WorksheetFunction.CountIfs(.Range("AA:AA"), wS2.Cells(k, (i - 2) * 8 + 2), .Range("B:B"), _ wS2.Cells(7, (i - 2) * 8 + 3)) If WorksheetFunction.CountIf(wS2.Columns((i - 2) * 8 + 2), wS2.Cells(k, (i - 2) * 8 + 2)) > 1 Then wS2.Cells(k, (i - 2) * 8 + 2).Resize(, 2).Delete shift:=xlUp End If Next k Next i wS2.Range("B1").CurrentRegion.Borders.LineStyle = xlContinuous wS2.Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole .Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole wS3.Cells.Clear .AutoFilterMode = False End With Application.ScreenUpdating = True End Sub このコードで検索をかけるSheet1のセルBの文字をセルCに移動して検索かけたいという事なのですが、下記の用なコードでBをCに変更してみた結果エラーが発生してしまいます。 lastRow = .Cells(Rows.Count, "C").End(xlUp).Row Range(.Cells(5, "C"), .Cells(lastRow, "C")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★ For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row wS2.Cells(7, (i - 2) * 8 + 3) = wS3.Cells(i, "A") .Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A") Range(.Cells(5, "AA"), .Cells(lastRow, "AA")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(7, (i - 2) * 8 + 2) For k = wS2.Cells(Rows.Count, (i - 2) * 8 + 2).End(xlUp).Row To 7 Step -1 wS2.Cells(k, (i - 2) * 8 + 3) = WorksheetFunction.CountIfs(.Range("AA:AA"), wS2.Cells(k, (i - 2) * 8 + 2), .Range("C:C"), _ どなたかご教授の方お願い致します。

  • Excel VBA 連番印刷

    昨日以下の質問をさせていただいた者です。 http://okwave.jp/qa/q8349562.html こちらで教えていただいた以下のコードに、 J2のセルに連番を振るコードを付け足したいと思い、 同じくこちらのサイトの過去の履歴にあった以下コードを参考にとやってみているのですが、 Next で指定された変数の参照が無効です。と言われてしまいます… 印刷部数の指定はいらず、sheet印刷のJ2セルに1から始まる連番を振りたいのです。 どのように修正をしたらいいのかご教示願います。 Sub Sample4() Dim i As Long, endRow1 As Long, endRow2 As Long, myArea1 As Range, myArea2 As Range Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet Set wS1 = Worksheets("DB") Set wS2 = Worksheets("印刷") Set wS3 = Worksheets("Sheet3") endRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row Range(wS1.Cells(1, "A"), wS1.Cells(endRow1, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True wS1.Range("A:A").Copy wS3.Range("A1") wS1.ShowAllData For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row If endRow2 > 9 Then Range(wS2.Cells(10, "B"), wS2.Cells(endRow2, "H")).ClearContents Range(wS2.Cells(10, "J"), wS2.Cells(endRow2, "J")).ClearContents End If wS1.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A") wS2.Range("B6") = wS3.Cells(i, "A") Set myArea1 = Range(wS1.Cells(2, "B"), wS1.Cells(endRow1, "H")).SpecialCells(xlCellTypeVisible) Set myArea2 = Range(wS1.Cells(2, "I"), wS1.Cells(endRow1, "I")).SpecialCells(xlCellTypeVisible) myArea1.Copy wS2.Activate ActiveSheet.Range("B10").Select Selection.PasteSpecial Paste:=xlPasteValues myArea2.Copy wS2.Activate ActiveSheet.Range("J10").Select Selection.PasteSpecial Paste:=xlPasteValues endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row 'Range(wS2.Cells(1, "A"), wS2.Cells(endRow2, "J")).PrintOut Next i wS1.AutoFilterMode = False wS3.Cells.Clear End Sub 連番印刷のコード Sub NumberPrint() Dim idx As Integer Dim res  res = Application.InputBox("印刷部数を入力してください", Type:=1)  If res > 0 Then   For idx = 1 To res    Range("AW3").Value = idx    ActiveSheet.PrintOut   Next idx  End If End Sub

  • VBAが止まります。

    皆さん、いつもありがとうございます。 下から14行目の『 objMail.Attachments.Add asrs1』で止まってしまします。 下から14行目の『 objMail.Attachments.Add asrs1』で止まってしまします。 asrs1をadrs1へ修正したりしましたが、改善されません。 昨日まで動いたいたのですが。 皆様、修正方法を教えていただけますでしdょうか。 ------------------------------------------------------- Sub メール作成() Dim objOutlook As Outlook.Application Dim objMail As Outlook.MailItem Dim wsMail As Worksheet Dim filead As String Dim tenp1 As String Dim tenp2 As String 'メール立ち上げ Set objOutlook = New Outlook.Application Set wsMail = ThisWorkbook.Sheets("リスト") '添付ファイルのアドレスを変数にする filead = Worksheets("リスト").Range("B3").Value '共通添付データのアドレスを読む tenp1 = filead & "\" & Worksheets("リスト").Range("B4") tenp2 = filead & "\" & Worksheets("リスト").Range("B5") Dim kobetsumail1 As String Dim kobetsumail2 As String Dim adrs1 As String Dim asrs2 As String '変数iを設定。最初は1 Dim i As Long i = 1 '送付前の確認メッセージ Dim rc As Long rc = MsgBox("記載に誤りが無いことを確認しましたか?", vbYesNo + vbQuestion, "確認") If rc = vbNo Then MsgBox "中断しました" End End If '基準となるセルを選択 Worksheets("リスト").Select Range("B7").Select '取引先名が書かれているB列が空欄になるまで続ける Do Until ActiveCell.Offset(i, 0).Value = "" '送付チェック欄が○なら作業を続ける If ActiveCell.Offset(i, 2).Value = "○" Then Set objMail = objOutlook.CreateItem(olMailTtem) '個別メールのデータ名称を読む Dim CC12(1) As String CC12(0) = ActiveCell.Offset(i, 6).Value CC12(1) = ActiveCell.Offset(i, 8).Value 'メールを作成する With wsMail objMail.to = ActiveCell.Offset(i, 4).Value objMail.CC = Join(CC12, ";") objMail.Subject = Range("B1").Value objMail.Bodyformat = olFormatPlain objMail.body = Range("B7").Offset(i, 0) & vbCrLf & Range("E7").Offset(i, 0) & "様" & vbCrLf & vbCrLf & Range("B2").Value & vbCrLf & vbCrLf kobetsumail1 = ActiveCell.Offset(i, 9).Value asrs1 = filead & "\" & kobetsumail1 kobetsumail2 = ActiveCell.Offset(i, 10).Value asrs2 = filead & "\" & kobetsumail2 If Range("B4").Value <> "" Then objMail.Attachments.Add tenp1 End If If Range("B5").Value <> "" Then objMail.Attachments.Add tenp2 End If If ActiveCell.Offset(i, 9).Value <> "" Then objMail.Attachments.Add asrs1 End If If ActiveCell.Offset(i, 10).Value <> "" Then objMail.Attachments.Add asrs2 End If objMail.Display objMail.Save End With End If i = i + 1 Loop Set objOutlook = Nothing MsgBox "下書きに保管しました" End Sub

専門家に質問してみよう