- ベストアンサー
実行時エラー配列のインデックスが範囲内にありません
- アウトルックvbaで、受信トレイのメールをすべてループして、該当のメールを削除するコードを作ったのですが、連続して削除しようとすると実行時エラー-2147352567「配列のインデックスが範囲内にありません」になります。
- 使用しているコードは、アウトルックの受信トレイにあるメールを順番に処理し、特定の条件に一致するメールを削除するものです。しかし、連続してメールを削除しようとすると配列のインデックスが範囲外になるエラーが発生します。
- このエラーは、Fornextステートメントを使用しているために発生している可能性があります。詳細な原因はわかりませんが、安定してループ処理を行うためには、配列の範囲外アクセスに注意する必要があります。
- tngqxktcbu5
- お礼率100% (29/29)
- オフィス系ソフト
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
関連するQ&A
- GetNamespaceで、コンパイルエラー
アクセスからアウトルックの受信メールを操作しようとしているのですが Private Sub test1() Dim requestsFolder As MAPIFolder Dim appNameSpace As Namespace Dim requestMailItem As MailItem Dim i As Integer '受信フォルダの取得 Set appNameSpace = Application.GetNamepace("MAPI") Set requestsFolder = appNameSpace.GetDfaultFolder(olFolderInbox) ・ ・ ・ End Sub これを実行すると GetNamespaceで、コンパイルエラーになります。 Microsoft Outlook ○.○ Object Library で、アウトルックに参照設定はしているのですが アクセスからはGetNamespaceは使えないのでしょうか？
- ベストアンサー
- オフィス系ソフト
- ダイレクトに目的のフォルダを指定する方法は？
全てのフォルダをループするのではなく、 ダイレクトに目的のフォルダを指定する方法はありますか？ アクセスからアウトルックの該当のフォルダの中身を取得したいのですが 下記コードで目的通り取得できるのですが コードが遠回りの気がします。 ダイレクトにフォルダを指定する方法があれば教えてください。 Sub test() Dim myNaSp As Namespace Dim myFolder As MAPIFolder Dim mySecFolder As MAPIFolder Dim myThrFolder As MAPIFolder Dim FolderName As String Dim myItem As MailItem Dim myindex As Long Set cn = CurrentProject.Connection Set myNaSp = GetNamespace("MAPI") For Each myFolder In myNaSp.GetDefaultFolder(olFolderInbox).Folders For myindex = 1 To myFolder.Items.Count Set myItem = myFolder.Items(myindex) If myFolder.Name = "ｔｅｓｔフォルダ" Then Debug.Print myItem.Body End If Next Next Set myNaSp = Nothing Set myFolder = Nothing End Sub
- ベストアンサー
- オフィス系ソフト
- EXCELの配列で
メールの本文を1行づつよみとってEXCELへ書き出そうと思っています。 Sub getMail1() Dim myOl As New Outlook.Application Dim dFolder As MAPIFolder Dim myItem As MailItem Dim delItem As MailItem Dim myRecipient As Recipient Dim i As Long, j As Long Const mAddress = 0, mTel = 1, mName = 2, mAge = 3 Set dFolder = myOl.GetNamespace _ ("MAPI").Folders("個人用フォルダ").Folders("単発") i = 1 On Error Resume Next For Each myItem In dFolder.Items i = i + 1 Set delItem = myItem.Reply For Each myRecipient In delItem.Recipients If InStr(1, myRecipient.Address, "@", vbBinaryCompare) _ <> 0 Then Exit For End If Next delItem.Delete With ActiveSheet myBody = Split(myItem.Body, vbCrLf) .Cells(i, 1).Value = myRecipient.Address .Cells(i, 2) = myItem.SenderName .Cells(i, 3) = myItem.Subject .Cells(i, 4) = myItem.ReceivedTime For j = 0 To UBound(myBody) i = i + 1 On Error Resume Next .Cells(i, 1) = myBody(j) .Cells(i, 1).MergeCells = True Next End With i = i + 1 Next Set myOl = Nothing End Sub このようなコードを書いて書き出すことは出来たのですが配列が縦になってしまいます。 横に配列したいのですが教えてください。 伊藤太郎 東京都 03-3123-4567を 伊藤太郎 東京都 03-3123-4567 としたいです。 よろしくお願いします。
- ベストアンサー
- Visual Basic
- 実行時エラー９：インデックスが有効範囲にありません」ができてた。調べた
実行時エラー９：インデックスが有効範囲にありません」ができてた。調べたのですが、原因は分からない、皆さん、助けてください。 以下はあるフォルダーを選定して、セルの値と一致するファイルを探し出して、シートＡの中のデータを取り上げて、コピーしたいです。けど、エラーが出てきた。皆さん。よろしくお願いします。 Sub test() Dim forName, bookName As String Dim x, y, l As Long Const cnsDIR = "\*.xls" Dim bFound As Boolean Dim myBook, actBook As Workbook Dim mySheet, actSheet As Worksheet With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then myPath = .SelectedItems(1) End If End With forName = Dir(myPath, vbDirectory) If Dir(myPath, vbDirectory) = "" Then MsgBox "It's nothing!", vbExclamation Exit Sub End If bFound = False For x = 2 To 7 Step 1 bookName = Dir(myPath & cnsDIR, vbNormal) Do While bookName <> "" l = InStrRev(bookName, ".xls") If Mid(bookName, l - 4, 4) = Format(Cells(4, x), "0000") Then bFound = True Exit Do 'hang/lie Else bookName = Dir() End If Loop If bFound = False Then Rtn = MsgBox("This is no found. Do you want to continue?", vbYesNo, "選択") If Rtn = vbNo Then Exit For End If Windows(bookName).Activate actSheet = ActiveWorkbook.Sheets For Each actSheet In Worksheets If ActiveSheet.Name = "A" Then Application.Union(Range("C55:F55"), Range("H55:I55")).Copy ThisWorkbook.Sheets(4).Range("B5").PasteSpecial Paste:=xlValues, Transpose:=True End If Next Next x End Sub
- ベストアンサー
- Visual Basic
- ExcelVBAで実行時エラーが出ます
このようなマクロを作りました。 Sub WriteCsv() Dim myTxtFile As String, myFNo As Integer Dim myLastRow As Long, i As Long Dim j As Long Dim aaa As Worksheet Set aaa = ActiveSheet Application.ScreenUpdating = False j = 0 myTxtFile = ActiveWorkbook.Path & "\Adress List.txt" Worksheets("List").Activate myLastRow = Range("A4").End(xlDown).Row myFNo = FreeFile Open myTxtFile For Output As #myFNo －－－－－※ For i = 4 To myLastRow If Cells(i, 3) = 1 Then Write #myFNo, Cells(i, 5) j = j + 1 End If Next Close #myFNo ・・・・ ・・・・ このExcelをフォルダーから実行するとすると、※で[ランタイムエラー５２]が発生しますが、デスクトップから実行すると出ません。 どのように修正すればいいんでしょうか？ よろしくお願いします。
- ベストアンサー
- その他MS Office製品
- 実行時エラー9 インデックスが有効範囲にありません！
プログラムを編集するところ、実行時エラー９：インデックスが有効範囲にありません」ができてた。調べたのですが、原因は分からない、皆さん、助けてください。 以下はあるフォルダーを選定して、セルの値と一致するファイルを探し出して、シートＡの中のデータを取り上げて、コピーしないです。けど、エラーが出てきた。皆さん。よろしくお願いします。 Sub test() Dim forName, bookName As String Dim x, y, l As Long Const cnsDIR = "\*.xls" Dim bFound As Boolean Dim myBook, actBook As Workbook Dim mySheet, actSheet As Worksheet With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then myPath = .SelectedItems(1) End If End With forName = Dir(myPath, vbDirectory) If Dir(myPath, vbDirectory) = "" Then MsgBox "It's nothing!", vbExclamation Exit Sub End If bFound = False For x = 2 To 7 Step 1 bookName = Dir(myPath & cnsDIR, vbNormal) Do While bookName <> "" l = InStrRev(bookName, ".xls") If Mid(bookName, l - 4, 4) = Format(Cells(4, x), "0000") Then bFound = True Exit Do 'hang/lie Else bookName = Dir() End If Loop If bFound = False Then Rtn = MsgBox("This is no found. Do you want to continue?", vbYesNo, "選択") If Rtn = vbNo Then Exit For End If Windows(bookName).Activate actSheet = ActiveWorkbook.Sheets For Each actSheet In Worksheets If ActiveSheet.Name = "A" Then Application.Union(Range("C55:F55"), Range("H55:I55")).Copy ThisWorkbook.Sheets(4).Range("B5").PasteSpecial Paste:=xlValues, Transpose:=True End If Next Next x End Sub
- ベストアンサー
- Visual Basic
- やはり図形のクリアで実行時エラー1004
図形を二行三列で一枡とし図形を貼り付けていますが、どうしても実行時エラー 「1004」が出て図形のクリアができません。(尚、四角形は枠線上にあります。) 対処法がありましたらお願いします。 Windows7・SP1 Office2010 Sub 図形の貼付け() Dim i As Integer Dim j As Integer For i = 10 To 43 Step 2 For j = 9 To 99 Step 3 Select Case Cells(i, j).Value Case 1: ActiveSheet.Shapes("四角形1").Select Selection.Copy Cells(i + 1, j + 1).Select ActiveSheet.Paste Case 2: ActiveSheet.Shapes("四角形2").Select Selection.Copy Cells(i + 1, j).Select ActiveSheet.Paste Case 4: ActiveSheet.Shapes("四角形3").Select Selection.Copy Cells(i + 1, j + 1).Select ActiveSheet.Paste Case 5: ActiveSheet.Shapes("四角形3").Select Selection.Copy Cells(i + 1, j + 2).Select ActiveSheet.Paste Case 6: ActiveSheet.Shapes("円1").Select Selection.Copy Cells(i, j).Select ActiveSheet.Paste End Select Next Next End Select End Sub Sub 図形のクリア() Dim myRng As Range Set myRng = Range("I10:CW43") Dim n As Integer, sp As Variant For n = ActiveSheet.Shapes.Count To 1 Step -1 Set sp = ActiveSheet.Shapes(n) If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing (ここで実行時エラー1004になります。) Then sp.Delete End If Next Set myRng = Nothing End Sub
- ベストアンサー
- Visual Basic
- VBA実行時のエラー
下記のプログラムは私が作った物では無いのですが、作った方と連絡をとる事が出来なくなってしまった為、質問させて頂きます。 このプログラムをシートから実行した所 エラー：400『既にフォームは表示されています。モーダルにできません。』 なるものが表示されてしまいます。 またコードを記述する所から実行しますと 実行時エラー：１００４『アプリケーション定義またはオブジェクト定義のエラー』 となってしまいます。 私の努力が足りないのは重々承知ですが、解決する事が出来ません。 皆様のお力を借りることが出来たらと思い投稿しました。 宜しくお願い致します。 Sub syoutotumen() Dim i As Long Dim j As Long Dim k As Long Dim kyori As Long Dim n As Integer n = 1 i = 1 j = 1 k = 1 Const cnsYEN = "\" Dim xlAPP As Application Dim objWBK As Workbook Dim strPATHNAME As String Dim strFILENAME As String strPATHNAME = "C:\Documents and Settings\tata41\デスクトップ\画像処理\" If strPATHNAME = "" Then Exit Sub strFILENAME = Dir(strPATHNAME & "dem******", vbNormal) If strFILENAME = "" Then MsgBox "このフォルダにはExcelワークブックは存在しません" Exit Sub End If Set xlAPP = Application With xlAPP .ScreenUpdating = False .EnableEvents = Fales .EnableCancelKey = xlErrorHandler .Cursor = xlWait End With Set WS1 = Worksheets("sheet1") Range("A1") = "0" Range("A2") = "1" Range("A1:A2").Select Selection.AutoFill Destinaton:=Range("A1:A512") Do While strFILENAME <> "" DoEvents If swESC = True Then If MsgBox("ESCが押されました。ここで終了しますか？", vbInformation + vbYesNo) = vbYes Then GoTo Button1_Click_Exit Else swESC = False End If End If xlAPP.StatusBar = trFILENAME & "処理中..." Set objWBK = Workbooks.Open(Filename:=strPATHNAME & cnsYEN & strFILENAME, UpdateLinks:=False, ReadOnly:=True) Do If Cells(i, 2) = 255 Then Exit Do i = i + 1 Loop Do If Cells(j, 3) = 255 Then Exit Do j = j + 1 Loop Do If Cells(k, 4) = 255 Then Exit Do k = k + 1 Loop kyori = (i + j + k - 21) / 3 WS1.Cells(n, 2) = kyori n = n + 1 i = 1 j = 1 k = 1 objWBK.Close savechanges:=False strFILENAME = Dir Loop GoTo Button1_Click_Exit Button1_Click_ESC: If Err.Number = 18 Then swESC = True Resume ElseIf Err.Number = 1004 Then Resume Next Else MsgBox Err.Description End If Button1_Click_Exit: With xlAPP .StatusBar = False .ScreenUpdating = True .EnableEvents = True .EnableCancelKey = xlInterrupt .Cursur = xlDefault Set objWBK = Nothing Set xlAPP = Nothing End With End Sub
- ベストアンサー
- オフィス系ソフト
- ＶＢＡ マクロ実行にてエラーが出ますが、原因を教えてください
下記コードを実行すると、myCell.Selectのところで 実行時エラー’91’ オブジェクト変数またはWithブロック変数が設定されていません。 というエラーが出るのですが、どうすれば対策出来るのでしょうか？ Sub test() Dim i As Long Dim myCell As Range With Range("A1").CurrentRegion For i = 2 To .Rows.Count Step 2 If i = 2 Then Set myCell = .Rows(i) Else Set myCell = Application.Union(myCell, .Rows(i)) End If Next i End With myCell.Select End Sub
- ベストアンサー
- Visual Basic
- Outlook内のZipをフォルダに送るスクリプト
Outlookに送られてくるメール内のZipファイルをあるサーバーのフォルダに送りたいのですが、どうもEnd Subエラーが出てうまくいきません。下記のVBスクリプトを見ていただき回答をいただければ助かります。どうぞよろしくお願いいたします。 Public Sub Application_Startup() Call MailParser End Sub Private Sub Application_NewMail() Call MailParser End Sub Public Sub MailParser() Dim objContactsFolder, objContactItem, intItemCounter Dim tdystart As Date Const olFolderContacts = 6 '6 (Inbox) subject line 5 (Sent) uses mail subject line 10 (Contacts) uses full name Dim MyTempFolderString As String MyTempFolderString = "" Dim Mydate Mydate = DateFix Set objContactsFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts) Set SubFolder = objContactsFolder.Folders("Inbox") ' Example ("AAA") intItemCounter = SubFolder.Items.Count If intItemCounter = 0 Then Exit Sub 'position counter for the item Set objContactItem = SubFolder.Items(intItemCounter) 'set to last email Set mymailitem = SubFolder.Items(intItemCounter) For I = 1 To intItemCounter Step 1 DoEvents Dim TempDir As String TempDir = "" Set mymailitem = SubFolder.Items(I) 'check for source If InStr(mymailitem.Subject, "Outlook内のファイル件名が入ります") <> 0 Then MyTempFolderString = "\\フォルダ名が入ります\" ElseIf InStr(mymailitem.Subject, "上と同じOutlook内のファイル件名が入ります") <> 0 Then MyTempFolderString = "\\上と同じフォルダ名が入ります\" End If If MyTempFolderString = "" Then GoTo NextI myAttachCount = mymailitem.Attachments.Count 'set counter for number of attachments Do Until myAttachCount = 0 DoEvents Set myAttachments = mymailitem.Attachments myAttachments.Item(myAttachCount).SaveAsFile MyTempFolderString & Mydate & myAttachments.Item(myAttachCount).DisplayName Loop NextI: Next I End Function Function OpenOutlookFolder(StrFolderPath As String) As Outlook.MAPIFolder Dim arrFolders As Variant, _ varFolder As Variant, _ bolBeyondRoot As Boolean On Error Resume Next If StrFolderPath = "" Then Set OpenOutlookFolder = Nothing Else Do While Left(StrFolderPath, 1) = "\" StrFolderPath = Right(StrFolderPath, Len(StrFolderPath) - 1) Loop arrFolders = Split(StrFolderPath, "\") For Each varFolder In arrFolders Select Case bolBeyondRoot Case False Set OpenOutlookFolder = Outlook.Session.Folders(varFolder) bolBeyondRoot = True Case True Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder) End Select If Err.Number <> 0 Then Set OpenOutlookFolder = Nothing Exit For End If Next End If On Error GoTo 0 End Function Function DateFix() If Len(Month(Now)) < 2 Then strMM = "0" & Month(Now) Else strMM = Month(Now) End If If Len(Day(Now)) < 2 Then strDD = "0" & Day(Now) Else strDD = Day(Now) End If DateFix = Year(Now) & "_" & strMM & "_" & strDD End Function
- 締切済み
- その他（インターネット・Webサービス）
お礼
なるほど。 逆にループすればよいのですね。有難うございます。