オブジェクト? inputboxで入力した日付を検索して複数選択 unionの使い方がわからない

このQ&Aのポイント
  • オブジェクトが必要ですというエラーが発生しています。inputboxで入力した日付を検索し、複数の値を選択したいとしていますが、unionの使い方がわかりません。どこが間違っているか、または足りていない部分があれば教えてください。
  • VBAでグラフ作成のためのコードを記述していますが、inputboxで入力した日付を検索し、それに一致するセルを選択したいと考えています。しかし、unionの使い方が正しくないようで、オブジェクトが必要ですというエラーが発生しています。解決策を教えてください。
  • VBAを使用してグラフ作成をしようとしています。inputboxで入力された日付を検索し、それに一致するセルを選択したいと思っていますが、unionの使い方が正しくないようです。エラーが発生し、オブジェクトが必要ですと表示されます。どうすればよいでしょうか?
回答を見る
  • ベストアンサー

オブジェクト??

またまた困っております 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) ↑ここでエラーが起きて 「オブジェクトが必要です」と言われました どうすればよいのでしょうか?

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

  • ベストアンサー
  • eden3616
  • ベストアンサー率65% (267/405)
回答No.2

セルにどのような値が入っており、どのような結果を得たいかが明確に記述されず コードだけ書かれた場合想定できる範囲に限界があります。 ご質問のコードより読みとれる範囲で作成した添付画像のデーたを用いて 最下のコードで実行しましたが完走いたします。 問題を具体的にご提示ください。 (1)対象のシート名は「VBA」である Const SH_NAME As String = "VBA" Set ws = ThisWorkbook.Worksheets(SH_NAME) (2)B列の最終行を検索対象の最終行とし endrow = .Cells(Rows.Count, 2).End(xlUp).Row For i = 2 To endrow ~ Next (3)A列の各行が入力値(日付)と一致しているか判定 If art = .Range("A" & i) Then ~ Else ~ End If (4)入力値以外かつ、重複していないA列の一覧をダイアログ表示 If InStr(msg, .Range("A" & i)) = 0 Then msg = msg & .Range("A" & i) & vbCrLf End If MsgBox msg Option Explicit ■修正後のVBAコード 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 If target Is Nothing Then Set target = Range("D" & i) Else Set target = Union(target, "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 target.Select End With If msg <> "" Then MsgBox msg End If MsgBox "グラフベースを作成しました" End Sub

その他の回答 (1)

  • eden3616
  • ベストアンサー率65% (267/405)
回答No.1

Set target = Union(target, "D" & i) ヘルプを見て頂いたらわかるのですが、Rangeオブジェクトを指定する必要があります。 「"D" & i」ではなく「Range("D" & i)」や「Cells(i, 4)」など。 またtargetに初期のRangeを指定しておく必要があります。 ですので以下のような感じでどうでしょ。 Set target = Union(target, "D" & i) の部分を以下のように修正 If target Is Nothing Then Set target = Range("D" & i) Else Set target = Union(target, "D" & i) End if 以下はunionの使用サンプルです。 (A列1,3,5,7,9行目を選択します) Sub test() Dim i As Long Dim myRange As Range Set myRange = Range("A1") For i = 3 To 9 Step 2 Set myRange = Union(myRange, Range("A" & i)) Next i myRange.Select End Sub

lostsymbol
質問者

お礼

ありがとうございます! そこの問題は解決しました!(^^)! でもそうしたら次は target.select のところでエラーが起きてしまいました(・_・;) 変数を設定しろと言われたのですがどうすればいいんでしょう、、、 お手数ですがよろしくお願いします、、

lostsymbol
質問者

補足

訂正です、、、 さきほど最初の問題が解決したと言いましたが、 また同じエラーが起こるようになってしまいました 教えていただいたところを直した以外は上のコードと同じです 何度もすいませんがよろしくお願いします(~_~;)

関連するQ&A

  • 小数点以下表示

    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

  • 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で複数列からの条件指定でデータを抽出したい

    講習会の受講者名簿を作成しています。(名簿は科目別で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

  • オブジェクトが必要です

    またまた困ってます、、 このコードを実行したとき .Range("H" & i).Copy.wsDetail.Range ("D24") ここでエラーが起きて 「オブジェクトが必要です」 と言われてしまいます(・・;) だれかよろしくお願いします<m(__)m> ※シートの宣言は上でやってます Private Sub 社会保険() Dim i Dim endrow As Long Dim kihon As Long Set wshoken = Worksheets("各種保険料表") Set wsDetail = Worksheets("給与明細") Set wsData = Worksheets("データ入力") kihon = WorksheetFunction.Round(wsData.Range("C5"), -4) endrow = Cells(Rows.Count, 3).End(xlUp).Row With wshoken For i = 2 To endrow If kihon = .Range("C" & i) Then .Range("H" & i).Copy.wsDetail.Range ("D24") .Range("L" & i).Copy.wsDetail.Range ("H24") .Range("N" & i).Copy.wsDetail.Range ("L24") Application.CutCopyMode = False End If Next i End With End Sub

  • PasteSpecialメソッドの失敗

    会社でVBAの勉強をしているのですが、 自分でコードを書いてみたところエラーが出て困っております 初心者なのでエラーの意味もわからずここにきました みなさまよろしくお願いします(・・;) Sub nigate() Const SH_NAME As String = "おはようございます" Dim i Dim ws As Worksheet Dim writerow As Integer Dim endrow As Long Set ws = ThisWorkbook.Worksheets(SH_NAME) writerow = 2 With ws endrow = .Cells(Rows.Count, 2).End(xlUp).Row .Columns("M:N").Clear For i = 2 To endrow If Range("D" & i).Font.ColorIndex = 3 Then Range("C" & i).Copy Range("L" & writerow) .PasteSpecial xlPasteAllExceptBorders writerow = writerow + 1 Application.CutCopyMode = False ElseIf Range("D" & i).Interior.ColorIndex = 36 Then Range("C" & i).Copy Range("K" & writerow) .PasteSpecial xlPasteAllExceptBorders writerow = writerow + 1 Application.CutCopyMode = False End If Next i End With End Sub これを実行すると、 PasteSpecialメソッドは失敗しました`Worksheet`オブジェクト と表示され止まってしまいます コードで言うと .PasteSpecial xlPasteAllExceptBorders のところが黄色くなります よろしくお願いしますm(__)m

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

    講習会の受講者名簿を作成しています。(名簿は科目別で3つのシートに分かれています。) 現在下記モジュールで、受講者名・受講者番号を検索出来るようにしていますが、 別シートに次回受講日(例:2014/4/1~2014/4/31)で受講者を抽出できるようにしたいと考えています。 しかし、受講予定日は過去のものも含め複数列(I列~N列)まであります。 このような場合、どのようにしたら受講日で検索が可能になるでしょうか? 宜しくお願いします。 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

  • Excel VBA 入力規則

    入力規則を利用して、3つのセルを連携させることを考えていますが、 不適合な値を張り付けらられた場合に拒否をする方法があるのでしょうか。 Private Sub Worksheet_Change(ByVal Target As Range) Dim ad As String Dim ma As Range Dim ma2 As Range Dim r As Range Dim r2 As Range Dim r3 As Range Dim r1 As Range Dim m As Long Dim m2 As Long Application.EnableEvents = False If Target = "" Then Range("F7").Validation.Delete Range("F7") = "" If Target.Address(0, 0) = "B7" Then Range("D7").Validation.Delete Range("D7") = "" End If GoTo EXIT_SUB End If With Worksheets("Sheet1") ad = "A4" Set r = .Range(ad) Set ma = r.MergeArea Set r1 = r.Offset(0, 1) m = Application.Match(Range("B7"), .Range(r1, .Cells(r.Row + ma.Count - 1, r1.Column)), 0) Set r2 = .Cells(r.Row + m - 1, r1.Column) Set ma2 = r2.MergeArea If Target.Address(0, 0) = "B7" Then If ma.MergeCells Then setValiS Target.Offset(0, 2), r2 Range("F7").Validation.Delete Target.Offset(0, 2) = "" Target.Offset(0, 4) = "" Else MsgBox "A列が連結されていません。" End If ElseIf Target.Address(0, 0) = "D7" Then Set r3 = r2.Offset(0, 1) m2 = Application.Match(Target, .Range(r3, .Cells(r2.Row + ma2.Count - 1, r3.Column)), 0) setValiS Target.Offset(0, 2), .Cells(r2.Row + m2 - 1, r3.Column) Target.Offset(0, 2) = "" End If End With EXIT_SUB: Application.EnableEvents = True End Sub Sub setVali2() Dim tc As Range Dim c As Range Set tc = Worksheets("登録").Range("D3") Set c = Worksheets("Sheet1").Range("C3") setValiS tc, c End Sub Sub setValiS(tc As Range, c As Range) Dim ss As String Debug.Print tc.Address, c.Address ss = getChildren(c) If ss > "" Then With tc.Validation .Delete .Add Type:=xlValidateList, Formula1:=getChildren(c) End With End If Worksheets("登録").Activate End Sub Function getChildren(c As Range) Dim c1 As Range Dim ss As String Dim s1 As String Worksheets("Sheet1").Activate ss = "" For Each c1 In c.MergeArea s1 = c1.Offset(0, 1) If s1 <> "" Then ss = ss & "," & s1 Next c1 If ss <> "" Then ss = Mid(ss, 2) Else MsgBox "データがありません!" End If getChildren = ss End Function Sub Outline() Dim CheckRow As Long Dim Moji As String Dim TopRow As Long Dim EndRow As Long With ActiveSheet .Range("A2").ClearOutline .Outline.SummaryRow = xlAbove CheckRow0 = .Range("A" & .Rows.Count).End(xlUp).Row CheckRow = CheckRow0 Do If Moji = "" Then Moji = .Cells(CheckRow, 1).Value EndRow = CheckRow ElseIf yy_mm(CDate(.Cells(CheckRow, 1).Value)) = yy_mm(CDate(Moji)) Then TopRow = CheckRow If TopRow = 1 Then .Rows(TopRow + 1 & ":" & EndRow).Rows.Group Exit Do End If Else .Rows(TopRow + 1 & ":" & EndRow).Rows.Group CheckRow = CheckRow + 1 Moji = "" End If CheckRow = CheckRow - 1 Loop Until CheckRow = 1 .Rows(CheckRow + 1 & ":" & EndRow).Rows.Group .Outline.ShowLevels RowLevels:=1 ExecuteExcel4Macro "SHOW.DETAIL(1," & CheckRow0 & ",TRUE)" End With End Sub Function yy_mm(d As Date) yy_mm = Format(d, "yy/mm") End Function

  • rangeメソッドは失敗しました

    またまたエラーが起きてしまいました、、 D列にある数値の平均値を出すマクロを組みたいのですが そのD列は今後増えていくので変数を使い指定したいのです Option Explicit Public Sub all() Const SH_NAME As String = "VBA" Dim i Dim endrow As Long Dim ws As Worksheet Dim Result As Integer Set ws = ThisWorkbook.Worksheets(SH_NAME) With ws endrow = .Cells(Rows.Count, 4).End(xlUp).Row For i = 2 To endrow Result = Application.WorksheetFunction.Average(.Range("D2:D&i")) .Range("F39").Value = Result .Range("F39").NumberFormatLocal = "0.00" Next i End With End Sub このコードだと Result = Application.WorksheetFunction.Average(.Range("D2:D&i")) のところでrangeメソッドは失敗しました と言われてしまいます どうかよろしくお願いします<m(__)m>

  • ExcelのAutoFilter への変数の使用がうまく行きません!

    ExcelのAutoFilter への変数の使用がうまく行きません! Windows XP Home Edition SP3 Office XP Personal 2002 Excel 2002 下記の NNN に 「 InputBox に 入力した整数 」 を変数で使用したいのですが、 どのようにすればよろしいでしょうか? 何卒、ご教示のほどをお願い致します。 Sub TEST1() Dim NNN As Integer Dim msg As String Dim i As Integer Application.ScreenUpdating = False   msg = "【整数】 を入力してください。"   NNN = InputBox(msg)   If ActiveSheet.AutoFilterMode Then    With ActiveSheet.AutoFilter    For i = 88 To 90    .Range.Rows(1).Cells(i).AutoFilter Field:=i, Criteria1:="<=NNN" '←この NNN です    Next i   End With   End If Application.ScreenUpdating = True End Sub

  • VBAのファイル参照について

    セルの変更時、列によって行の内容を変更するプログラムを組んだのですが、 エラーが起きてうまくいきません。 使用しているExcelは2007です。 ファイルを参照するあたりが全然わかってないのでそのあたりがあやしいです。 実行時エラー '91': オブジェクト変数または With ブロック変数が設定されていません。 → hoge = book1.Worksheets(customer).Range("A34:D" & endrow) '係数表をコピー ↓デバッグ押すと 実行時エラー '-2147417848 (80010108)': 'Value' メソッドは失敗しました: 'Range'オブジェクト → Call all_feeCulc_change2(target.Parent.Name, target.row) 番号をメモし忘れました。91かこれが表示されます。どちらが出るかわかりません。 'Range' メソッドは失敗しました:'_Worksheet' オブジェクト →endrow = book1.Worksheets(customer).Cells(Rows.Count, 1).End(xlUp).row '最終行番号を取得 何回かリトライして開いたり閉じたりを繰り返したら↓のようなダイアログも出ました。 マクロでスタック領域が不足しています また、ダイアログで終了を押したらセルを正しく選択できなくなりました。 デバッグを押したら、停止ボタンを押すと応答なしになった後、Excelが終了し再起動しました。 そして、どちらを選択した場合でも、メニューや閉じるボタンを押してもExcelが終了できず、 タスクマネージャからプロセスを終了させるしかなかったです。 その時CPU使用率が50%を超えてたりと異常事態になっております。 ###標準モジュール### Sub all_feeCulc_change2(ByVal sheetName As String, ByVal row As Integer) If sheetName <> "" Then Dim customer As String customer = Worksheets(sheetName).Cells(row, 3) On Error Resume Next Dim book1 As Workbook '別ファイルのオープン(触らない) Workbooks.Open Filename:="hogehoge.xlsm" '別ファイルのオープン(触らない) Set book1 = Workbooks("hogehoge.xlsm") '別ファイルのオープン(触らない) On Error GoTo 0 Dim endrow As Integer '最終行番号 endrow = book1.Worksheets(customer).Cells(Rows.Count, 1).End(xlUp).row '最終行番号を取得 Dim hoge As Variant hoge = book1.Worksheets(customer).Range("A34:D" & endrow) '早見表から係数表をコピー With Worksheets(sheetName) ... ###ThisWorkbook### Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal target As Range) If target.Count = 1 Then Dim column As Integer Dim row As Integer column = target.column row = target.row If row >= 3 Then If ((column - 3) Mod 5) = 2 And column > 3 Then '更新セルがメーターだったら Call usageCulc_change(target.Parent.Name, target.column, target.row) Call all_feeCulc_change(target.Parent.Name, target.column - 1, target.row) Call chenge_tax_change(target.Parent.Name, target.column + 1, target.row) ElseIf column = 3 Then target.Value = format(target.Value, "000") '誤入力防止 Call all_feeCulc_change2(target.Parent.Name, target.row) Call chenge_tax_change2(target.Parent.Name, target.row) End If End If End If End Sub Private Sub Workbook_Open() '*****すべてのシート名を取得*****' Dim ws As Worksheet Dim sheetName() As String ReDim sheetName(3) Dim cnt As Integer cnt = 0 For Each ws In Worksheets If cnt > 3 And (cnt Mod 4) = 0 Then ReDim Preserve sheetName(UBound(sheetName) + 4) End If sheetName(cnt) = ws.Name cnt = cnt + 1 Next '*****取得終了*****' Dim endrow As Integer Dim line As Variant For Each line In sheetName If line <> "000" And line <> "" Then With Worksheets(line) endrow = .Cells(Rows.Count, 3).End(xlUp).row Dim i As Integer Dim j As Integer For i = 0 To endrow For j = 0 To 11 .Cells(3 + i, 4 + j * 5).NumberFormatLocal = "0.0" .Cells(3 + i, 5 + j * 5).NumberFormatLocal = "0.0" .Cells(3 + i, 6 + j * 5).NumberFormatLocal = "#,##0" .Cells(3 + i, 7 + j * 5).NumberFormatLocal = "#,##0" .Cells(3 + i, 8 + j * 5).NumberFormatLocal = "#,##0" Next j Next i End With End If Next End Sub

専門家に質問してみよう