• 締切済み

エクセル VBAのオートフィルター実行時エラー

エクセル VBAのオートフィルター実行時エラーについて教えて下さい VBAのオートフィルター実行時エラーで「’rangeクラスのAutoFilterメッソドが失敗しました’」 が表示されるのですが、エラーの内容がわかりません。教えて下さい。 Sub 複数条件でのデータ抽出() Const OrigSheetName = "データベース" Const PasteSheetName = "検索&抽出" Const ItemRow = 2 Const FirstColumn = "A" Const LastColumn = "CH" Const UnnecessaryColumns = "W:CD" Const SearchColumn1 = "CF" Const SearchColumn2 = "I" Const PasteCell = "A2" Dim OrigSheet As Worksheet, PasteSheet As Worksheet, _ LastRow As Long, Region As Variant, Period(1, 1) As Variant, _ temp As Variant, i As Long, c As Range Period(0, 0) = "1905/1/1" Period(1, 0) = "9999/12/31" Period(0, 1) = "以降" Period(1, 1) = "以前" If IsError(Evaluate("ROW('" & OrigSheetName & "'!A1)")) Then MsgBox "元データが入力されているシートとして設定されている" _ & vbCrLf & vbCrLf & OrigSheetName & vbCrLf & vbCrLf & _ "というシート名のシートが見つかりません。" & vbCrLf _ & "マクロを終了します。", vbExclamation, "存在しないシート" Exit Sub End If Set OrigSheet = Sheets(OrigSheetName) If IsError(Evaluate("ROW('" & PasteSheetName & "'!A1)")) Then MsgBox "データの転記先のシートとして設定されている" _ & vbCrLf & vbCrLf & PasteSheetName & vbCrLf & vbCrLf & _ "というシート名のシートが見つかりません。" & vbCrLf _ & "マクロを終了します。", vbExclamation, "存在しないシート" Exit Sub End If Set PasteSheet = Sheets(PasteSheetName) With OrigSheet LastRow = .Range(LastColumn & Rows.Count).End(xlUp).Row With .Range(LastColumn & Rows.Count).End(xlUp) If LastRow > .Row Then LastRow = .Row End With If LastRow <= ItemRow Then GoTo label9 label1: Region = Application.InputBox("参加または不参加を入力!", SearchColumn2 & _ "列に入力されている区分(A組またはB組)の中で、抽出条件を入力して下さい", _ , Type:=6) If Region = vbNullString Or Region = False Then temp = MsgBox("区分が入力されていません。" & vbCrLf _ & "区分の入力をやり直しますか?" & vbCrLf & vbCrLf _ & "[はい]:区分の入力をやり直します" & vbCrLf _ & "[いいえ]:処理を中止してマクロを終了します", _ vbYesNo + vbExclamation, "区分未入力") If temp = vbNo Then Exit Sub Else GoTo label1 End If End If For i = 0 To 1 label2: Period(i, 0) = Application.InputBox("期間指定" & i + 1, SearchColumn1 & _ "列に入力されている日付" _ & "で抽出する期間を指定して下さい。", _ Period(i, 0), Type:=2) If Period(i, 0) = vbNullString Or Period(i, 0) = False Then temp = MsgBox("日付が入力されていません。" & vbCrLf _ & "日付の入力をやり直しますか?" & vbCrLf & vbCrLf _ & "[はい]:日付の入力をやり直します" & vbCrLf _ & "[いいえ]:処理を中止してマクロを終了します", _ vbYesNo + vbExclamation, "日付未入力") If temp = vbNo Then Exit Sub Else GoTo label2 End If End If If IsDate(Period(i, 0)) Then If Format(Period(i, 0), "yyyy/mm/dd") = DateValue(Period(i, 0)) & "" _ Then GoTo label3 End If temp = MsgBox("入力された値は日付として扱う事が出来ません。" _ & vbCrLf & "日付の入力をやり直して下さい。", _ vbOKOnly + vbExclamation, "入力値不適切") GoTo label2 label3: Period(i, 0) = DateValue(Period(i, 0)) Next i End With With Application .ScreenUpdating = False .Calculation = xlManual End With With OrigSheet .Columns(UnnecessaryColumns).Hidden = True With .Range(SearchColumn1 & ItemRow & ":" & SearchColumn2 & LastRow) .AutoFilter Field:=1, Criteria1:=Region .AutoFilter Field:=Columns(SearchColumn1 & ":" & SearchColumn2).Columns.Count, _ Criteria1:=">=" & Period(0, 0), Operator:=xlAnd, Criteria2:="<=" & Period(1, 0) End With Set c = .Range(FirstColumn & ItemRow & ":" & LastColumn & LastRow) i = c.Resize(, 1).SpecialCells(xlCellTypeVisible).Cells.Count End With If i > 1 Then With PasteSheet .Range(PasteCell & ":" & .Cells.SpecialCells(xlCellTypeLastCell).Address).Clear c.SpecialCells(xlCellTypeVisible).Copy With .Range(PasteCell) .PasteSpecial Paste:=xlPasteValuesAndNumberFormats .PasteSpecial Paste:=xlPasteFormats End With End With End If With c.EntireColumn .AutoFilter .Hidden = False End With If i > 1 Then GoTo labelE label9: MsgBox DateCell & "該当するデータが見つかりません。" & vbCrLf _ & "マクロの実行を中止します。", vbExclamation, "データ無し" & vbCrLf & i labelE: With Application .CutCopyMode = False .Calculation = xlAutomatic .ScreenUpdating = True End With End Sub 1か月ほど前までは問題なく実行出来ていました。元のデータベースの表を編集(列の追加)しましたが、元となるセルは変更しています。 宜しくお願いします!

みんなの回答

  • ushi2015
  • ベストアンサー率51% (241/468)
回答No.1

こんにちは コードのどこでエラーになりますか? 列を追加したとの事ですが、列の定数の内容は変更しましたか? 例えば、定数の宣言からすると AutoFilter Field:=Columns(SearchColumn1 & ":" & SearchColumn2).Columns.Count は  AutoFilter Field:=Columns("CF:I").Columns.Count って事になりますけど、 AutoFilter Field:=76 という意味で合ってますか? 定数やら変数が沢山出てきますけど、エラーになった時のAutoFilter部分の 構文をチェックしましたか?

関連するQ&A

  • エクセル VBAのオートフィルター実行時エラー

    VBAのオートフィルター実行時エラーで「’rangeクラスのAutoFilterメッソドが失敗しました’」 が表示されるのですが、エラーの内容がわかりません。教えて下さい。 Sub 複数条件でのデータ抽出() Const OrigSheetName = "データベース" Const PasteSheetName = "検索&抽出" Const ItemRow = 2 Const FirstColumn = "A" Const LastColumn = "CH" Const UnnecessaryColumns = "W:CD" Const SearchColumn1 = "CF" Const SearchColumn2 = "I" Const PasteCell = "A2" Dim OrigSheet As Worksheet, PasteSheet As Worksheet, _ LastRow As Long, Region As Variant, Period(1, 1) As Variant, _ temp As Variant, i As Long, c As Range Period(0, 0) = "1905/1/1" Period(1, 0) = "9999/12/31" Period(0, 1) = "以降" Period(1, 1) = "以前" If IsError(Evaluate("ROW('" & OrigSheetName & "'!A1)")) Then MsgBox "元データが入力されているシートとして設定されている" _ & vbCrLf & vbCrLf & OrigSheetName & vbCrLf & vbCrLf & _ "というシート名のシートが見つかりません。" & vbCrLf _ & "マクロを終了します。", vbExclamation, "存在しないシート" Exit Sub End If Set OrigSheet = Sheets(OrigSheetName) If IsError(Evaluate("ROW('" & PasteSheetName & "'!A1)")) Then MsgBox "データの転記先のシートとして設定されている" _ & vbCrLf & vbCrLf & PasteSheetName & vbCrLf & vbCrLf & _ "というシート名のシートが見つかりません。" & vbCrLf _ & "マクロを終了します。", vbExclamation, "存在しないシート" Exit Sub End If Set PasteSheet = Sheets(PasteSheetName) With OrigSheet LastRow = .Range(LastColumn & Rows.Count).End(xlUp).Row With .Range(LastColumn & Rows.Count).End(xlUp) If LastRow > .Row Then LastRow = .Row End With If LastRow <= ItemRow Then GoTo label9 label1: Region = Application.InputBox("参加または不参加を入力!", SearchColumn2 & _ "列に入力されている区分(A組またはB組)の中で、抽出条件を入力して下さい", _ , Type:=6) If Region = vbNullString Or Region = False Then temp = MsgBox("区分が入力されていません。" & vbCrLf _ & "区分の入力をやり直しますか?" & vbCrLf & vbCrLf _ & "[はい]:区分の入力をやり直します" & vbCrLf _ & "[いいえ]:処理を中止してマクロを終了します", _ vbYesNo + vbExclamation, "区分未入力") If temp = vbNo Then Exit Sub Else GoTo label1 End If End If For i = 0 To 1 label2: Period(i, 0) = Application.InputBox("期間指定" & i + 1, SearchColumn1 & _ "列に入力されている日付" _ & "で抽出する期間を指定して下さい。", _ Period(i, 0), Type:=2) If Period(i, 0) = vbNullString Or Period(i, 0) = False Then temp = MsgBox("日付が入力されていません。" & vbCrLf _ & "日付の入力をやり直しますか?" & vbCrLf & vbCrLf _ & "[はい]:日付の入力をやり直します" & vbCrLf _ & "[いいえ]:処理を中止してマクロを終了します", _ vbYesNo + vbExclamation, "日付未入力") If temp = vbNo Then Exit Sub Else GoTo label2 End If End If If IsDate(Period(i, 0)) Then If Format(Period(i, 0), "yyyy/mm/dd") = DateValue(Period(i, 0)) & "" _ Then GoTo label3 End If temp = MsgBox("入力された値は日付として扱う事が出来ません。" _ & vbCrLf & "日付の入力をやり直して下さい。", _ vbOKOnly + vbExclamation, "入力値不適切") GoTo label2 label3: Period(i, 0) = DateValue(Period(i, 0)) Next i End With With Application .ScreenUpdating = False .Calculation = xlManual End With With OrigSheet .Columns(UnnecessaryColumns).Hidden = True With .Range(SearchColumn1 & ItemRow & ":" & SearchColumn2 & LastRow) .AutoFilter Field:=1, Criteria1:=Region .AutoFilter Field:=Columns(SearchColumn1 & ":" & SearchColumn2).Columns.Count, _ Criteria1:=">=" & Period(0, 0), Operator:=xlAnd, Criteria2:="<=" & Period(1, 0) End With Set c = .Range(FirstColumn & ItemRow & ":" & LastColumn & LastRow) i = c.Resize(, 1).SpecialCells(xlCellTypeVisible).Cells.Count End With If i > 1 Then With PasteSheet .Range(PasteCell & ":" & .Cells.SpecialCells(xlCellTypeLastCell).Address).Clear c.SpecialCells(xlCellTypeVisible).Copy With .Range(PasteCell) .PasteSpecial Paste:=xlPasteValuesAndNumberFormats .PasteSpecial Paste:=xlPasteFormats End With End With End If With c.EntireColumn .AutoFilter .Hidden = False End With If i > 1 Then GoTo labelE label9: MsgBox DateCell & "該当するデータが見つかりません。" & vbCrLf _ & "マクロの実行を中止します。", vbExclamation, "データ無し" & vbCrLf & i labelE: With Application .CutCopyMode = False .Calculation = xlAutomatic .ScreenUpdating = True End With End Sub 1か月ほど前までは問題なく実行出来ていました。元のデータベースの表を編集(列の追加)しましたが、元となるセルは変更しています。 宜しくお願いします!

  • エクセルVBA実行エラーの対処方法

    以前教えていただいた構文ですが、NOWより過ぎてない日付がFirstRow 31より有り、過ぎた日付がない場合に実行するとエラーが出ます。これを回避するのを教えてください。 宜しくお願いします。 Const DateColumn = "B" '日付が入力されている列 Const FirstRow = 31 '削除の対象となる可能性がある最初の行 Dim LastRow With ActiveSheet LastRow = .Range(DateColumn & Rows.Count).End(xlUp).row If LastRow <= FirstRow Then MsgBox "処理すべきデータがありません。" _ & vbCrLf & "マクロを終了します。" _ , vbExclamation, "データ無し" Exit Sub End If With Application .ScreenUpdating = False .Calculation = xlManual End With .Range(DateColumn & FirstRow - 1 & ":" & DateColumn & LastRow) _ .AutoFilter Field:=1, Criteria1:="<=" & Now, _ Field:=1, Criteria2:="", Operator:=xlOr .Range(DateColumn & FirstRow & ":" & DateColumn & LastRow) _ .SpecialCells(xlCellTypeVisible).EntireRow.Delete .Cells.AutoFilter End With With Application .CutCopyMode = False .Calculation = xlAutomatic .ScreenUpdating = True End With

  • エクセルVBA  どうしても動きません。

    お世話になります。 なかなか上達しない超初心者です。 ↓↓ですが、Activesheetにすると動くのに、シート名を元々存在するシート”実験"に指定すると動きません(データ内容はまったく同じで、A列に色んな名前が入っていて、重複しているとC列に重複と入力します)。 2日間試行錯誤したのですが、やっぱり動かず・・・ ちなみに、Activateにするとアクティブになるし、CurrentRegionも選択できるのに なんでうごかないんでしょうか・・・ 何卒ご指導くださいませ。よろしくお願いいたします!!!!!! Sub Test2() With Sheets("実験").Range("A1").CurrentRegion Dim i As Long Dim LastRow As Long LastRow = Range("A" & Rows.Count).End(xlUp).Row For i = 1 To LastRow If WorksheetFunction.CountIf(Range("A:A"), Cells(i, 1)) > 1 Then Cells(i, 3) = "重複" End If Next i End With End Sub Sheets("実験")をActivesheetに変えると別のシートがしっかり動いてくれます・・・が、なんとしてでも”実験”シートに動いていただきたいです・・・。

  • VBA実行時のエラー

    下記のプログラムは私が作った物では無いのですが、作った方と連絡をとる事が出来なくなってしまった為、質問させて頂きます。 このプログラムをシートから実行した所 エラー:400『既にフォームは表示されています。モーダルにできません。』 なるものが表示されてしまいます。 またコードを記述する所から実行しますと 実行時エラー:1004『アプリケーション定義またはオブジェクト定義のエラー』 となってしまいます。 私の努力が足りないのは重々承知ですが、解決する事が出来ません。 皆様のお力を借りることが出来たらと思い投稿しました。 宜しくお願い致します。 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

  • VBA 実行時エラー'1004' オートフィルタ

    お世話になります。Excel2003を使っております。 初歩的なことかもしれませんが、 原因がよくわかっていないため、教えて下さい。 フォームにあるコンボボックスのデータ 特定のシートの絞り込みを行います。 '========================= If ComboBox1 <> "" Then '空じゃないときに実行 With ThisWorkbook.Worksheets("データ") .Select .Range("A1").Select .Range("A1").AutoFilter Field:=ThisWorkbook.Worksheets("データ").Range("E1").Column, _ Criterial:=Me.ComboBox1.Text End With End if '========================= 上記のようなプログラムを書いてみましたが、 何故かエラーが出ます。 このような書き方ではまずいのでしょうか? 前までは、 '========================= Worksheets("データ").Select '基データを選択 If ComboBox1.Text <> "" Then '製品名が空じゃない場合 Selection.AutoFilter Field:=Range("E1").Column, _ Criteria1:=ComboBox1.Text End If '================== 上記の方法で行っていました。(上手くいっていました。) SELECT(Selection)を使うのはあまり良くないと聞いたため このようにWithを使って書いているのですが 実行時エラー '1004' アプリケーション定義またはオブジェクト定義のエラーです。 と出ます。 回答よろしくおねがい致します。

  • エクセルVBAラベルの変数?

    エクセル2000VBAにて下記のように作成しました。 With ActiveSheet For i = 4 To 200 If Label1.Caption = .Cells(i, 1) Then For h = 4 To 34 If Label25.Caption = .Cells(2, h) Then For idx = i To 200 If .Cells(idx, 3) = Label21.Caption Then Label6.Caption = .Cells(idx, h) Label7.Caption = .Cells(idx + 2, h) GoTo ラベル2 End If Next idx End If Next h End If Next i ラベル2: For i = 4 To 200 If Label2.Caption = .Cells(i, 1) Then For h = 4 To 34 If Label25.Caption = .Cells(2, h) Then For idx = i To 200 If .Cells(idx, 3) = Label21.Caption Then Label8.Caption = .Cells(idx, h) Label9.Caption = .Cells(idx + 2, h) GoTo ラベル3 End If Next idx End If Next h End If Next i ラベル3: ・・・ End With Label1~5まで同じ処理を行うため 1~5まで変数を使用して簡単にしたいのですが Label(変数)の書き込み方がわかりません? 検索を使用しましたが検索項目が悪いのか なかなか解決しません。 何方か教えていただけないでしょうか?

  • エクセルVBAなぜ実行時エラーが?

    エクセル2000です。 DATAと名づけた表の値を変換し、最大値から端数をプラマイするマクロなのですが、途中で「実行時エラー91 オブジェクト変数またはWithブロック変数が設定されていません。」となってしまいます。 なぜ出るかわからないので別なBookに同じ名前のRange をつくり同様の表でためしたらエラーにならずちゃんと作動します。 本番用のBookでのみエラーがでます。なぜなのでしょうか? 実行時エラーのでる With Range("DATA").Find(mx, LookIn:=xlValues) .Value = .Value + dff ' End With を、Withブロックをつかわず Range("DATA").Find(mx, LookIn:=xlValues).Select で試しても本番のBookではエラーになります。ほんとに困っています。 Sub 調整() Dim r As Double Dim c As Range Dim dff As Integer, mx As Long r = 25000 / Range("初期").Value With Sheets("内訳") Range("DATA").Value = .Range("F57:L73").Value '初期値複写 'MsgBox "初期値転写完了" For Each c In Range("DATA") If c.Value <> "" Then c.Value = Application.WorksheetFunction.Round(c.Value * r, -1) End If Next 'MsgBox "初期変換完了" dff = 25000 - Range("変換後") If dff <> 0 Then 'MsgBox dff mx = Application.WorksheetFunction.Max(Range("DATA")) 'MsgBox mx With Range("DATA").Find(mx, LookIn:=xlValues) .Value = .Value + dff 'ここで実行時エラー! End With End If End With End Sub

  • excel vbaについてです

    VBA初心者で、暇な時にいろいろためしています。 以下のマクロを組んだのですが、エラーがでてうまくいきません。 どこがいけないのかご指摘願います。 Sub ather() Dim A As Range Dim B As Range Dim i As Integer With ThisWorkbook.Worksheets("Sheet1") For i = 1 To 30 Set A = Cells(i, 1) Set B = Cells(1, i) If Not .Range(A).Interior.ColorIndex = vbYellow Then GoTo port10 If Not .Range(B).Interior.ColorIndex = vbRed Then GoTo port10 .Range(B).Offset(, 1).Value = "○" port10: Next i End With End Sub イメージとしてはセルの塗りつぶしが黄色で、かつ右隣のセルの塗りつぶしが赤の時に、 赤色セルの右隣のセルに○を表示させようとしているのですが。。。 こうしたらいいんじゃない?といったアドバイスもお願いします(-人-)

  • エクセルVBAで困っています。

     エクセルでSheet1でSheet2に各銀行の出納帳を作りそこから各項目ごとに別Sheetに振り分けたいと思っています。  ある方にエクセルVBAで作って頂いたのですが、最初作って頂いた時の項目は会費、会議費、事務費の3つでした。その項目を9つに増やしたいと思っています。又、全てのSheetで1行目には銀行名や項目名を入れたいので2行目から日付、内容・・・といったように入力したいです。そうした場合、どこをどう変更したらよいのか分かりません。自分がわかる範囲で(適当ですが)挑んでみたのですが、私自体VBAについて全く無知のため何が何だかサッパリです。どなたか教えて頂くことはできないでしょうか。ちなみに文字数に制限があったため改行やスペースなどは入れていません。見難いとは思いますがよろしくお願いします。どうか皆様のお知恵を貸して頂けると幸いです。 Option Explicit Sub Teller() '【考え方】Sheet1とSheet2を入力と考える。 'マクロを実行したときに、Sheet1,2を元に、項目別に振り分ける。 Const BankName1 As String = "○銀行" Const BankName2 As String = "(チェック)銀行" Const tempSheet As String = "一時シート" Dim classify(9) As String Dim title(5) As String Dim i As Long Dim j As Long Dim lastRow1 As Long Dim lastRow2 As Long Dim findUpper As Long Dim findLower As Long Dim keyword As String Dim ws As Worksheet Dim Bank1 As Worksheet Dim Bank2 As Worksheet Dim Temp As Worksheet Set Bank1 = Worksheets(BankName1) Set Bank2 = Worksheets(BankName2) '【振り分ける項目名】 classify(1) = "会費" classify(2) = "会議費" classify(3) = "事務費" classify(4) = "事業費" classify(5) = "研修費" classify(6) = "報償費" classify(7) = "慶弔費" classify(8) = "予備費" classify(9) = "積立金" '【1行目に記載する見出し】 title(1) = "日付" title(2) = "内容" title(3) = "収入" title(4) = "支出" title(5) = "残高" '画面更新を停止 Application.ScreenUpdating = False '最終行取得 Bank1.Select lastRow1 = Cells(Rows.Count, 1).End(xlUp).Row Bank2.Select lastRow2 = Cells(Rows.Count, 1).End(xlUp).Row 'シートを作る For i = 1 To 3 Call MakeNewSheet_As_ThisName(classify(i)) For j = 1 To 5 Cells(1, j) = title(j) Next j Next i Call MakeNewSheet_As_ThisName(tempSheet) Cells.ClearContents Set Temp = Worksheets(tempSheet) '一時シートに、銀行1のデータと銀行2のデータをコピーする。 Bank1.Select Bank1.Range(Cells(3, 1), Cells(lastRow1, 5)).Copy Temp.Select Temp.Range(Cells(1, 1), Cells(lastRow1 - 2, 5)).PasteSpecial Bank2.Select Range(Cells(3, 1), Cells(lastRow2, 5)).Copy Temp.Select Cells(lastRow1 - 1, 1).PasteSpecial 'ソートする。 '第一優先キー:B列。[項目]昇順。 '第二優先キー:A列。[日付]昇順。 Range("A1:E" & (lastRow1 + lastRow2 - 4)).Select With ActiveWorkbook.Worksheets(tempSheet).Sort .SortFields.Clear .SortFields.Add Key:=Range("B1:B" & (lastRow1 + lastRow2 - 4)), Order:=xlAscending '第一キー .SortFields.Add Key:=Range("A1:A" & (lastRow1 + lastRow2 - 4)), Order:=xlAscending '第二キー .SetRange Range("A1:E" & (lastRow1 + lastRow2 - 4)) .Apply End With For i = 1 To 3 keyword = classify(i) findUpper = 0 findLower = 0 '上から探す For j = 1 To lastRow1 + lastRow2 - 4 Step 1 If Cells(j, 2) = keyword Then findUpper = j Exit For End If Next j If findUpper > 0 Then '下から探す For j = lastRow1 + lastRow2 - 4 To 1 Step -1 If Cells(j, 2) = keyword Then findLower = j Exit For End If Next j 'コピー Range(Cells(findUpper, 1), Cells(findLower, 5)).Copy Sheets(keyword).Select Range("A2").Select ActiveSheet.Paste Range("B2:B" & 2 + (findLower - findUpper)).Delete Shift:=xlToLeft Sheets(tempSheet).Select End If Next i '一時シートの削除 Application.DisplayAlerts = False Temp.Delete Application.DisplayAlerts = True 'アクティブセルをA1にしておく For Each ws In Worksheets Sheets(ws.Name).Select 'シート選択 Application.CutCopyMode = False Range("A1").Select Next ws Bank1.Select '画面更新を行う Application.ScreenUpdating = True MsgBox "実行しました" End Sub Sub MakeNewSheet_As_ThisName(ByVal GivenName As String) 'シートの有無を確認し、無ければ作る Dim exist_flag As Boolean Dim ws As Worksheet exist_flag = False For Each ws In Worksheets If UCase(ws.Name) = UCase(GivenName) Then 'シートが存在する場合 exist_flag = True Exit For End If Next ws 'シートを作成 If GivenName = "" Then MsgBox "空白名のシートは作れません。" ElseIf exist_flag = False Then Sheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Name = GivenName End If Sheets(GivenName).Select 'シート選択 End Sub

  • エクセル VBA について

    エクセルで、 ダブルクリックしたら"*"を表示したい範囲に【入力】という名前をつけ、 ダブルクリックしたら9つ左のセルの内容を表示したい範囲に【金額】という名前をつけ、 二つの構文?をVisual Basicに作成したんですが、エラーが出てしまいます。 ひとつずつだと上手くいくのですが、なぜでしょうか? わかる方教えてください。 あと申し訳ないのですが、VBAはまったくわからないため、ネット上で構文をコピーして貼り付けました。 そんな者でもわかる修正の説明をお願いいたします。 以下が作成し、エラーとなってしまう構文です。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Const RangeName As String = "金額" If Target.Value = "" Then Target.Value = Target.Offset(0, -9).Value Cancel = True End If End Sub 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

専門家に質問してみよう