- ベストアンサー
実行エラー 3075: クエリ式作成日の間＃2010/10/01＃ AND ＃2010/10/30＃の構文エラーの処理方法
- 実行エラー 3075: クエリ式作成日の間＃2010/10/01＃ AND ＃2010/10/30＃の構文エラーが発生しました。このエラーの処理方法を教えてください。
- Private Sub cmdFilter_Click()の部分でエラーが発生しています。
- BuildCriteria関数を使用してクエリの条件を構築しています。
- nuocngoai
- お礼率43% (28/65)
- その他(データベース)
- 回答数4
- ありがとう数3
- みんなの回答 （4）
- 専門家の回答
質問者が選んだベストアンサー
その他の回答 (3)
- layy
- ベストアンサー率23% (292/1222)
- piroin654
- ベストアンサー率75% (692/917)
エラーの、 の間＃2010/10/01＃ AND ＃2010/10/30＃ は、本来 Between ＃2010/10/01＃ AND ＃2010/10/30＃ になるのが、Between の代わりに 「の間」 が 演算子として入ってしまっているからではと思いますが。 If fBetween Then strCriteria = strCriteria & strCondition _ & " #" & Format(varValue1, "yyyy/mm/dd") & "# AND #" _ & Format(varValue2, "yyyy/mm/dd") & "#" のところで、Betweenが入るのは、strConditionの ところですか。あるいは、 strCriteria = strCriteria & strCondition & "Between"_ とするのですか。
お礼
ありがとうございます。 これでエラーの原因だと思います。エラーが解決できました。
- piroin654
- ベストアンサー率75% (692/917)
コードが途中掲載なので、思いついたことだけ。 (1) With Me ここはエラー→ .Filter = strCriteria .FilterOn = True .Requery End With の部分をコメントアウトして、変わりに MsgBox strCriteria をいれて、strCriteria の内容を確認 してみては。 (2) #" & Format(varValue1, "yyyy/mm/dd") & "# などを、 '" & Format(varValue1, "yyyy/mm/dd") & "' にしてみるとか。 (3) あるいは、txtValue1とtxtValue2の値の 対象となるレコードのフィールドなりが テキスト型ならば、型を変更する。 あるいは、(2)をCaDate、Formatで 変更する。 (4) BuildCriteriaの他の引数にNullがないか。
補足
すみません、これは全部のコードです。元々は行けているんですが条件のリストボックスの中にBETWEENとLIKEという条件があって、私は「の間」と「類似」に変わりました。そこでこのエラーに出てしまったんです。類似という条件でうまく検索できますが「の間」だけではいけてないです txtValue1=ChangeProperty("cmdFilter") Private Function BuildCriteria(strFieldName As String, _ intType As Integer, _ strCondition As String, _ varValue1 As Variant, _ Optional varValue2 As Variant) As String Dim fBetween As Boolean Dim fLike As Boolean Dim strCriteria As String Const conQuotes = """" fBetween = IIf(InStr(strCondition, "の間") > 0, _ True, False) fLike = IIf(InStr(strCondition, "類似") > 0, _ True, False) strCriteria = strFieldName & " " Select Case intType Case dbText, dbMemo If InStr(1, varValue1, "*") > 0 Then strCriteria = strCriteria _ & " Like " & conQuotes & varValue1 & conQuotes Else If fLike Then strCriteria = strCriteria & " Like " _ & conQuotes & "*" & varValue1 & "*" & conQuotes Else strCriteria = strCriteria & strCondition _ & " " & conQuotes & varValue1 & conQuotes End If End If Case dbInteger, dbLong, dbCurrency, dbDouble, dbSingle If fBetween Then strCriteria = strCriteria _ & strCondition & " " & varValue1 & " AND " & varValue2 Else strCriteria = strCriteria _ & strCondition & " " & varValue1 End If Case dbDate If fBetween Then strCriteria = strCriteria & strCondition _ & " #" & Format(varValue1, "yyyy/mm/dd") & "# AND #" _ & Format(varValue2, "yyyy/mm/dd") & "#" Else strCriteria = strCriteria _ & strCondition & " #" & Format(varValue1, "yyyy/mm/dd") & "#" End If Case Else strCriteria = strCriteria _ & strCondition & " " & varValue1 End Select BuildCriteria = strCriteria End Function
関連するQ&A
- シート保護をすると実行エラーになります。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Intersect(Target, Range("A1:A2000")) Is Nothing Then Exit Sub With Selection.Interior If .ColorIndex = xlNone Then .ColorIndex = 4 Else .ColorIndex = xlNone End If End With Cancel = True End Sub Ａ列任意のセルをダブルクリックすると色が変わるコードを組んでいます。しかしながら、 Ａ列のみロックを解除したのち、シート保護をすると、上記の実行がエラーになります。 どのようにすればエラーを回避できるのかお知恵をかしていただければ幸いです。
- ベストアンサー
- オフィス系ソフト
- 実行時エラー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
- 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
- ベストアンサー
- オフィス系ソフト
- 【ExcelVBA】 既にあるマクロの間で実行させたいのです。
こんにちは 下のマクロを・・・ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Const RangeName As String = "●入力" If Not Intersect(Range(RangeName), Target) Is Nothing Then Cancel = True If Target = "●" Then Target = "" Else Target = "●" End If End If End Sub このマクロの■ここで実行■で実行させたいのですが、どのようにしたらよいでしょう。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Address <> "$D$1" Then Exit Sub Cancel = True Columns("A:U").Select Range("T1").Activate Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlYes, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _ :=xlPinYin, DataOption1:=xlSortNormal Selection.Replace What:="ああ", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Range("D1").Select End Sub ■ここで実行■ Private Sub Worksheet_Change(ByVal Target As Range) strAddress = "A1:A2000" On Error GoTo ErrorHandler If Target.Count > 1 Then GoTo ErrorHandler If Not Intersect(Target, Range(strAddress)) Is Nothing Then Application.EnableEvents = False Range(strAddress).ClearContents Target.Value = "●" End If ErrorHandler: Application.EnableEvents = True End Sub
- ベストアンサー
- オフィス系ソフト
- 実行時エラー９：インデックスが有効範囲にありません」ができてた。調べた
実行時エラー９：インデックスが有効範囲にありません」ができてた。調べたのですが、原因は分からない、皆さん、助けてください。 以下はあるフォルダーを選定して、セルの値と一致するファイルを探し出して、シートＡの中のデータを取り上げて、コピーしたいです。けど、エラーが出てきた。皆さん。よろしくお願いします。 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
- ＶＢＡ マクロ実行にてエラーが出ますが、原因を教えてください
下記コードを実行すると、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
- 生年月日から学年を計算しようと以下のようにVBを用いて作りました。が、
生年月日から学年を計算しようと以下のようにVBを用いて作りました。が、9月までは正しく学年が表示されたのですが、10月になったとたん、一つ前の学年が表示されるようになりました。 Function Jokyo(ByVal Umare As Variant) As String Dim idx As Integer Dim moji As String If IsNull(Umare) Then Jokyo = "" Exit Function End If '4月～12月での学齢計算 If Month(Date) >= "4" Then idx = DateDiff("yyyy", Umare, DateSerial(Year(Date), 4, 1)) If Format(Umare, "mmdd") < "0401" Then idx = idx + 1 End If ElseIf Month(Date) < "4" Then idx = DateDiff("yyyy", Umare, DateSerial(Year(Date) - 1, 4, 1)) If Format(Umare, "mmdd") < "0401" Then idx = idx + 1 End If Else idx = 19 End If '-------------------------------------------------- Select Case idx Case 0 To 4 moji = "未入学" Case 5 moji = "幼稚園年少" Case 6 moji = "幼稚園年長" Case 7 To 12 moji = "小学" & idx - 6 & "年生" Case 13 To 15 moji = "中学" & idx - 12 & "年生" Case 16 To 18 moji = "高校" & idx - 15 & "年生" Case Else moji = "既卒生" End Select Jokyo = moji End Function
- ベストアンサー
- オフィス系ソフト
- 下記のマクロをもっと早くするには？
下記のマクロは、 A列にあるURLがSSL化（https）されているかを調べるものです。 このマクロを動かすと、大体３秒に１つのURLを調べるくらいの早さです。 もっと早く調べられるようにするには、どのような記述にすればできるでしょうか？ また、エクセルの他の設定で、マクロを早くできたりしますか？ よろしくお願いいたします。 Sub SSL() Dim objHttp As Object Dim nURL As String Dim strURL As String Dim i As Long, f As String, l As String Dim Lastrow As Long, getLine As Long Set objHttp = CreateObject("WinHttp.WinHttpRequest.5.1") On Error GoTo ErrHandler 'A1から getLine = Cells(Rows.Count, 2).End(xlUp).Row Lastrow = Cells(Rows.Count, 1).End(xlUp).Row If getLine = Lastrow Then MsgBox "既に終わっているか、データがないです。", vbExclamation: Exit Sub If getLine < Lastrow And Cells(1, 2).Value <> "" Then getLine = getLine + 1 Else getLine = 1 '最初の行が1行目からの場合 End If For i = getLine To Lastrow strURL = LCase(Trim(Cells(i, 1).Value)) 'A列の登録URL strURL = Replace(strURL, "https:", "http:") If strURL Like "http*" Then objHttp.Open "GET", strURL, False objHttp.send DoEvents 'ESC割り込み可能にする With objHttp If .Status = 200 Then nURL = .Option(1) 'WinHttpRequestOption_URL f = Mid(strURL, 1, InStr(strURL, "://")) l = Mid(nURL, 1, InStr(nURL, "://")) If nURL = "" Then Cells(i, 2).Value = "no URL" ElseIf nURL <> "" Then If LCase(f) = LCase(l) Then Cells(i, 2).Value = "non SSL" Else Cells(i, 2).Value = "https" End If End If Else Cells(i, 2).Value = "Err:" & .Status End If End With End If Endline: nURL = "" strURL = "" Next i MsgBox "Finished" Exit Sub ErrHandler: If Err() <> 0 Then Cells(i, 2).Value = Err.Number 'マイナスになるのは外部エラー GoTo Endline End If End Sub
- 締切済み
- Visual Basic
- オブジェクト？？
またまた困っております 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) ↑ここでエラーが起きて 「オブジェクトが必要です」と言われました どうすればよいのでしょうか？
- ベストアンサー
- Visual Basic
- VBAの実行時エラー'2522'について
前任者がAccess2003により作成したデータベースがあります。 CSVデータを取り込む仕組みがあるのですが、下記のエラーが出て困っています。 実行時エラー '2522': このアクションまたはメソッドを実行するには[File Name/ファイル名]引数が必要です。 どうやらVBAによるエラーだと判明しましたが、それ以上はよくわかりません。 以下のような構文になっています。 Option Compare Database ---------- Private Sub CSV取込_Click() TextConv strFileName, "マスター定義", "T_マスター" End Sub ---------- Sub TextConv(strFle, strInp, strTbl) Dim strSQL As String strSQL = "DELETE * FROM " & strTbl If MsgBox("テーブルデータを更新しますか？", 4, "テーブル更新") = vbYes Then CurrentProject.Connection.Execute strSQL DoCmd.TransferText acImportDelim, strInp, strTbl, strFle, True MsgBox "テーブルデータを更新しました" End If End Sub ---------- Private Sub 参照_Click() Dim strFileName As String strFileName = GetFileName() If Len(strFileName) > 0 Then Me.filepath = strFileName Else MsgBox "取込対象ファイルを選択してください！ " End If End Sub 以上のようになっています。 デバッグを実行すると「strFle」の値がEmptyになっているのでここだとは思うのですが、どうしたらよいかわかりません。 どなたかお知恵をお貸し願えませんでしょうか。 宜しくお願いします。
- ベストアンサー
- オフィス系ソフト
お礼
お陰様でエラー解決できました。 ありがとうございます。