• ベストアンサー

VBA　アプリケーション定義またはオブジェクト定義のエラーです

VBA初心者です。 仕事中、暇な時にVBAの勉強をしています。 あるファイルのフォーマットを指定されたフォーマットに変換するプログラムを作成しています。 実行後、「アプリケーション定義またはオブジェクト定義のエラーです」と出て、先に進めません。 どなたが分かる方、ご教授お願い致します。 以下ソース Private Sub CommandButton1_Click() ' 変数定義 Dim openFileName As String Dim priorYearBudget As String, thisYearBudget As String, increaseAnddecrease As String Dim bigSection As String, mediumSection As String, smallSection As String Dim fileLastRow As Long, buf As Long, index As Long Dim head As String ' 初期化 index = 2 ' ファイル名取得 openFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls") If openFileName <> "False" Then ' ファイルが存在したらファイルを開く Workbooks.Open openFileName ' 項目を変数に格納 ' bigSection = Sheets(1).Cells(1, 3) ' mediumSection = Sheets(1).Cells(1, 4) ' smallSection = Sheets(1).Cells(1, 5) priorYearBudget = Sheets(1).Cells(1, 6) thisYearBudget = Sheets(1).Cells(1, 7) increaseAnddecrease = Sheets(1).Cells(1, 8) ' ファイルの最終行を取得(データが格納されている行) fileLastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row ' ワークシートの追加 Worksheets.Add after:=Worksheets("Sheet1") ' セルの幅指定 Columns("A").Select Selection.ColumnWidth = 70 Columns("B:D").Select Selection.ColumnWidth = 13 Columns("A").Select ' 幅設定で選択されたセルを解除 range("A1").Select ' 新規に追加されたワークシートに項目を設定 Sheets(2).Cells(1, 1).Value = "勘定科目" Sheets(2).Cells(1, 2).Value = priorYearBudget Sheets(2).Cells(1, 3).Value = thisYearBudget Sheets(2).Cells(1, 4).Value = increaseAnddecrease ' 元ファイルの見出しの形式を変更 For headCnt = 1 To fileLastRow head = Sheets(1).Cells(headCnt, 1) bigSection = Sheets(1).Cells(index, 3) midiumSection = Sheets(1).Cells(index, 4) smallSection = Sheets(1).Cells(index, 5) If head <> "" Then ' 項目設定 Sheets(2).Cells(headCnt, 1).Value = "【" & head & "】" End If If bigSection <> "" Then ' 大区分設定 Sheets(2).Cells(buf, 1).Value = bigSection←ここでエラー発生 ElseIf midiumSection <> "" Then ' 中区分設定 Sheets(2).Cells(buf, 1).Value = midiumSection ElseIf smallSection <> "" Then ' 小区分設定 Sheets(2).Cells(buf, 1).Value = smaillsection End If ' Sheets(2).Cells(cnt, 1).Value = head ' head = Sheets(1).Cells(cnt, 1) index = index + 1 buf = buf + 1 Next headCnt ' 元ファイルの金額をそのままコピー For budgetCnt = 2 To fileLastRow Sheets(2).Cells(budgetCnt, 2).Value = Sheets(1).Cells(budgetCnt, 6) Sheets(2).Cells(budgetCnt, 3).Value = Sheets(1).Cells(budgetCnt, 7) Sheets(2).Cells(budgetCnt, 4).Value = Sheets(1).Cells(budgetCnt, 8) Next budgetCnt Else MsgBox "キャンセルされました" Exit Sub End If End Sub 補足 エラーが発生する箇所をコメントアウトすると、正常に動作します。 よろしくお願い致します。

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

  • ベストアンサー
  • fujiponxx
  • ベストアンサー率32% (186/580)
回答No.1

bufが初期化されてないからのような気もするんですけどね。 どうでしょうね。

akito0417
質問者

お礼

回答有難う御座います。 bufを初期化して試してみましたが、結果は変わりませんでした。 どうやらVBAは勝手に0クリアされてるみたいです。

akito0417
質問者

補足

指摘された通り、bufを0クリアしている所為でした。 プログラムでは0オリジン、エクセルは1オリジンなんですよね・・・。 ありがとうございました。

その他の回答 (2)

  • fujiponxx
  • ベストアンサー率32% (186/580)
回答No.3

ちょっと実行してみましたが、 以下のところでエラーがでるようですが、ちがいますかね？ ＞Columns("A").Select Ａを全部選択するのであれば、自動マクロ記録すると以下のように なりますけども。 Columns("A:A").Select

  • Sinogi
  • ベストアンサー率27% (72/260)
回答No.2

なぜ　buf　が宣言されていないのかな? まぁ、それはともかくとして・・・ 掲示どおりのソースなら、エラー行までに　buf　に値を設定していないように思いますが? F8実行なりで該当行でのbuf値を確認しましたか?

akito0417
質問者

お礼

アドバイス有難う御座います。 bufは上の方で纏めて定義していますが、指摘していただいた通り、値を設定していないだけでした・・・。 有難う御座いました。

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. その他（プログラミング・開発）

関連するQ&A

  • VBA アプリケーション・オブジェクト定義のエラー

    ある行と別の行と同じ内容の文章が入っている場合、それを削除するマクロをくんでいますが、 アプリケーション・オブジェクト定義のエラーとのことで作動してくれません。。。 以下のような記述なのですが、アドバイスをいただけたら幸いです。 よろしくお願いいたします。 Sub 重複削除() Dim dataend Cells(Rows.Count, 5).End(xlUp).Select dataend = ActiveCell.Row For i = 2 To dataend - 1 For k = 1 To dataend - i If Cells(2, i).Value = Cells(2, i + k).Value Then '''''''''''''''''''''ここでひっかかる Rows(i + 1).Select Selection.Delete End If Next Next End Sub

  • VBA マクロ　エラー1004　アプリケーション定義またはオブジェクト定義のエラー

    VBAで正当表と入力表の正誤判定を一気に行いたいのですが If Cells(a, b).Value = Cells(c, d).Value Thenの部分で エラー1004、アプリケーション定義またはオブジェクト定義のエラーと出てしまいます。 エラーの対処の仕方を調べたのですがわかりませんでした。 教えていただけるとありがたいです。 以下作ったプログラムです。 Sub 正誤判定() Dim a Dim b Dim c Dim d Dim e Dim i Dim j Dim x Dim y Dim hokan Dim ytate Dim xyoko a = 3 b = 21 c = 3 d = 43 e = 2 i = 1 j = 1 Do While j < 261 Do While i < 11 If Cells(a, b).Value = Cells(c, d).Value Then a = a + 1 c = c + 1 If Cells(a, b) = Cells(c, d) Then hokan = Cells(e, b).Value ytate = Range("B2:S15").Find(hokan, lookat:=xwhole).Row + 15 xyoko = Range("B2:S15").Find(hokan, lookat:=xwhole).Column Cells(ytate, xyoko).Value = Cells(ytate, xyoko).Value + 1 Else End If Else End If a = a - 1 c = c - 1 b = b + 1 d = d + 2 i = i + 1 Loop a = a + 3 c = c + 3 e = e + 3 j = j + 1 Loop End Sub

  • VBAtest

    VBAおｎ以下の Sheets("ＯＰ").Select Dim atai As String atai = Cells(2, 2).Value Dim datedata(40) As String For j = 0 To 40 If Cells(j + 3, 2).Value = "" Then Else datedata(j) = Cells(j + 3, 2).Value End If Next Dim shihyou As String For i = 1 To 2 shihyou = Cells(2, i + 2).Cells.Value Sheets(shihyou).Select Dim tmp_c As Integer For r = 1 To 10 tmp_c = 0 For c = 1 To 10 If tmp_c = 0 Then If Sheets(shihyou).Cells(r, c).Value = atai Then tmp_c = c End If Else Dim vals(40) As String For k = 0 To 40 For l = 1 To r + 41 For m = 1 To tmp_c - 1 If Sheets(shihyou).Cells(l, m).Value = datedata(k) Then vals(k) = Sheets(shihyou).Cells(l, tmp_c).Value End If Next Next Next End If Next Next Sheets("ＯＰ").Select For k = 3 To 43 Cells(k, i + 2).Value = vals(k - 3) Next Next End Sub

  • 【VBA】セルの中身を日付形式に変換したい

    w列のセルの中に20140701のように入っているセルを2014/07/01に変換するマクロを作っております。 それで以下のように書いてみたのですが、「型が一致しません」と出てしまい、先に進めずにおります…。お力借りられますと幸いです。 Dim org As String Dim buf As String Dim i As Long i = 1 Do Until Cells("w", i) = "" Cells("w", i).Select With ActiveCell org = .Value If Len(org) = 8 Then buf = _ Mid(org, 1, 4) & "/" & _ Mid(org, 5, 2) & "/" & _ Mid(org, 7, 2) If IsDate(buf) = True Then .Value = buf .NumberFormatLocal = "yyyy年m月d日" End If End If End With i = i + 1 Loop

  • アプリケーションまたはオブジェクト定義のエラーです

    データを入力するシート「input]、データを格納するシート　「data」とがあり、 新規のレコードを追加入力するために 新規入力ボタン(CommandButton2)を作成しましたが、 実行しようとすると、表記のエラーが出てしまします。 コードの確認、とそして、どこがいけないのかをご指摘いただけないでしょうか？どうかよろしくお願いいたします。 以下コードです。 Private Sub CommandButton2_Click() '新規入力 Dim row As Integer row = Sheets("data").Cells(Rows.Count, 2).End(xlUp).Offset(1) Sheets("data").Cells(row, 2).Value = Sheets("data").Cells(row - 1, 2).Value Range("AL1") = Sheets("data").Cells(row, 2).Value End Sub

  • Excel VBAの繰返し処理を教えて下さい

    マクロを始めたばかりの初心者です。 どなたかご教示下さい。 リストから担当者社員番号をキーとして既定のシートにデータ転記し、別ファイルコピー後名前を付けて保存するというマクロを作成しています。 ご教示頂きたいのは、担当者別にファイルを作成したいのですが、 １行ごとの処理になり、無限ループでVBAが終了しません。 色々調べてみたものの、解決策が見つかりません。 どなたかご教示いただけないでしょうか。 読みにくいコードですが何卒よろしくお願い致します。 サンプルコード Sub 担当者用_個人用() Dim 行 As Integer Dim 年月 As String Dim メール行 As Integer Dim 担当者用 As String Dim 社員番号 As String Dim 社員名 As String Dim 残業対象 As String Dim 所属コード As String Dim 所属名 As String Dim 事業所コード As String Dim 事業所名 As String Dim 社員区分 As String Dim 平日時間外_m As String Dim 休日時間外_m As String Dim 時間外合計 As String Dim 前月時間外合計 As String Dim 前々月時間外合計 As String Dim 平均 As String Dim 問診票 As String Dim 削減書 As String Dim 担当者社員番号 As String Dim 担当者 As String Application.ScreenUpdating = False Sheets("個人用").Select 年月 = InputBox("ＯＴレポートの「年月」を入力してください　 　　例：（前月）2012年9月 →　201209") Range("A2") = 年月 Sheets("健康診断問診票").Select 行 = 5 メール行 = 5 　【こちらの繰返し処理が無限ループになっています。ご教示頂けないでしょうか】 　　　　　 Do Until Cells(行, 17).Value = "" If Cells(行, 17).Value <> 担当者社員番号 Then End If 出力処理: 社員番号 = Cells(行, 1).Value 社員名 = Cells(行, 2).Value 残業対象 = Cells(行, 3).Value 所属名コード = Cells(行, 4).Value 所属名 = Cells(行, 5).Value 事業所コード = Cells(行, 6).Value 事業所名 = Cells(行, 7).Value 社員区分 = Cells(行, 8).Value 平日時間外_m = Cells(行, 9).Value 休日時間外_m = Cells(行, 10).Value 時間外合計 = Cells(行, 11).Value 前月時間外合計 = Cells(行, 12).Value 前々月時間外合計 = Cells(行, 13).Value 平均 = Cells(行, 14).Value 問診票 = Cells(行, 15).Value 削減書 = Cells(行, 16).Value 担当者社員番号 = Cells(行, 17).Value 担当者 = Cells(行, 18).Value Sheets("個人用").Select Range("A5").Select Cells(メール行, 1).Value = 社員番号 Cells(メール行, 2).Value = 社員名 Cells(メール行, 3).Value = 残業対象 Cells(メール行, 4).Value = 所属名コード Cells(メール行, 5).Value = 所属名 Cells(メール行, 6).Value = 事業所コード Cells(メール行, 7).Value = 事業所名 Cells(メール行, 8).Value = 社員区分 Cells(メール行, 9).Value = 平日時間外_m Cells(メール行, 10).Value = 休日時間外_m Cells(メール行, 11).Value = 時間外合計 Cells(メール行, 12).Value = 前月時間外合計 Cells(メール行, 13).Value = 前々月時間外合計 Cells(メール行, 14).Value = 平均 Cells(メール行, 15).Value = 問診票 Cells(メール行, 16).Value = 削減書 Cells(メール行, 17).Value = 担当者社員番号 Cells(メール行, 18).Value = 担当者 '個別ファイル作成 Sheets("個人用").Select Sheets("個人用").Copy 年月 = Cells(2, "A") 担当者社員番号 = Cells(5, "Q") 担当者 = Cells(5, "R") Application.DisplayAlerts = False 'メッセージを出さない ActiveWorkbook.SaveAs Filename:="C:\担当者用\" & ("勤怠抽出" & 年月 & "(" & 担当者社員番号 & " " & 担当者 & "さん" & ")") & ".xls" ActiveWorkbook.Save ActiveWindow.Close Sheets("個人用").Select Rows("5:5").Select Range(Selection, Selection.End(xlDown)).Select Selection.ClearContents Sheets("健康診断問診票").Select 行の終わり: 行 = 行 + 1 Loop Sheets("ファイル作成").Select Range("A30").Select ActiveWorkbook.Save Application.ScreenUpdating = True MsgBox "ファイル作成が終了しました" End Sub

  • エクセル　ＶＢＡ　シートの選択　

    windows XP でエクセル２０００を使っています。 Sub aaa() Sheets("Sheet1").Select Dim a As String a = Cells(2, 4) Sheets(a).Select Range("A1").Select End Sub というマクロだと　セルに入っている値のシート名を探してくれます。 ですが Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) If Intersect(Target, Range("B11:b683")) Is Nothing Then Exit Sub Worksheets("Sheet1").Range("C2").Value = Target.Value Dim b As String b = Range("C2).value （←ここをcellsにしてもダメ） Sheets(b).Select Range("A1").Select End Sub これだとsheets(b)を選びません。Sheets(b).Selectのところが黄色くなります。 何処が間違えているのでしょうか。 全くの素人ですが、仕事で必要に迫られています。 わかりやすく回答・解説くれると助かります。

  • VBA　アプリケーション定義またはオブジェクト定義エラーについて

    doc_wbkというブックのSheets(2)の内容をdoc_wbk2のActiveSheetにコピーしようとしています。 以下のコードの5行目で「アプリケーション定義またはオブジェクト定義エラー」が出てしまいます。ブックやシートまで指定しないといけないのかと思い doc_wbk.Sheets(2) を5行目行頭に追加しましたが変わりません。逆に5行目行頭の . を外してやるとアクティブシートの内容をコピーしてしまいます。Sheets(2)の内容をコピーしてやるにはどうしたらよいでしょうか?よろしくお願いします。 Set doc_wbk = Workbooks.Open(doc_dir + doc_file, 0) With Sheets(2) If .Range("A4").Value <> "" Then row_num = .Range("a65536").End(xlUp).Row .Range(Cells(4, 1), Cells(row_num, 11)).Copy doc_wbk2.ActiveSheet.Cells(row_num2 + 1, 1) End If End With

  • 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

  • VBA 抽出後、別シートにコピー

    ＯＳはＸＰ、Ｅｘｃｅｌは２００３を使用しています。 下記は、元シートから新規シートにデータ全部をコピーする様に組んでいるのですが、これを利用して、Ａ列に「３」が入力されているデータのみを抽出して新規シートにコピーするしたいです。 Dim cellgyo As Long '［元シート］で注目している行 Dim kakikomigyo As Long '［新規シート］で書き込む Dim jigyosyocode As Variant '担当事業者コード Dim tantocode As Integer '担当者コード Dim tokuisakicode As Long '得意先コード Dim tokuisakiname As String '得意先名 Dim yomicode As String '読みコード Dim postcode As String '郵便番号 Dim add1 As String '住所１ Dim add2 As String '住所２ Dim telno As String '電話番号 Dim faxno As String 'FAX番号 kakikomigyo = 3 '［新規シート］に最初に書き始める行 For cellgyo = 2 To 63335 'Forループの始まり Sheets("元シート").Select '［元シート］シートを選択／Cells(行,列) ’**** jigyosyocode = Cells(cellgyo, 1).Value tantocode = Cells(cellgyo, 5).Value tokuisakicode = Cells(cellgyo, 2).Value tokuisakiname = Cells(cellgyo, 3).Value yomicode = Cells(cellgyo, 4).Value postcode = Cells(cellgyo, 16).Value add1 = Cells(cellgyo, 17).Value add2 = Cells(cellgyo, 18).Value telno = Cells(cellgyo, 19).Value faxno = Cells(cellgyo, 20).Value If jigyosyocode = "0" Then Exit For End If Sheets("新規シート").Select Cells(kakikomigyo, 1).Value = jigyosyocode 'Cells(行,列) Cells(kakikomigyo, 2).Value = tantocode Cells(kakikomigyo, 3).Value = tokuisakicode Cells(kakikomigyo, 4).Value = tokuisakiname Cells(kakikomigyo, 5).Value = yomicode Cells(kakikomigyo, 6).Value = postcode Cells(kakikomigyo, 7).Value = add1 Cells(kakikomigyo, 8).Value = add2 Cells(kakikomigyo, 9).Value = telno Cells(kakikomigyo, 10).Value = faxno kakikomigyo = kakikomigyo + 1 Next cellgyo ----------------------- ----------------------- データを抽出しようと思い、 Range("A1").Select Selection.AutoFilter Selection.AutoFilter Field:=1, Criteria1:="3" Selection.CurrentRegion.Copy を　****のところに挿入してみたのですが、 どうも上手く行きません。 説明の足りないところあるかと思いますが、 どなたか修正点教えて下さいますようお願いします。

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する