• 締切済み

【VBA】一番初めの処理に戻って、処理を繰り返す。

VBA初心者です。 コードはネットで調べて組み合わせて作っております。 今回は、組み合わせたコードで処理が終わってもフォルダ内のファイル数の数だけ処理を繰返したいです。 事前に作っているコードは、 ①データ読み取りをしたいExcelを開く、別ブックを開いて該当のセルに入力。セル自体に数式が入っているので各シートに反映されます。 ②inputboxで各シートの該当セルに表示させたい文字を入力。 ③3、4枚目のシートを選択。 ④名前をつけて保存する。 という作業のコードになっています。 ①~④までを行った後に、データ数に応じて処理を繰返し行いたいです。 下記のコードにしたところ、Nextに対応するForがありません。とエラーが出ます。End Ifは追加しているのにエラーが起きるのはなぜでしょうか? ---下記 コード--- Sub マスターデータ取込03() '選択したファイルを取り込み、別のファイルに貼り付ける。 For Each f In fso.GetFolder(folderpath).Files If fso.GetExtensionName Like "xls?" Then Set wb = Workbooks.Open(f) Dim RC As Integer Dim OpenFileName, FileName, Path, SetFile As String Dim wbMoto, wbSaki As Workbook Set wbMoto = ActiveWorkbook 'マスターデータ取り込み元をセット Application.DisplayAlerts = False RC = MsgBox("マスターデータ取込みますか?", vbYesNo + vbQuestion, "確認") If RC = vbYes Then OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?") 'ダイアログボックスを表示して、マスターデータファイルを指定します。 If OpenFileName <> "False" Then SetFile = OpenFileName Else MsgBox "キャンセルされました" Exit Sub 'マスターデータの取り込みをキャンセル End If Workbooks.Open FileName:=SetFile, ReadOnly:=True, UpdateLinks:=0 'ダイアログボックスで指定したマスターデータファイルを開きます。 Set wbSaki = Workbooks.Open(Path & SetFile) 'ワークブック間のシート「項目」をコピーします。 wbSaki.Worksheets("内訳書").Range("D:O").Copy wbMoto.Worksheets("見積入力").Range("U7").PasteSpecial xlPasteValues Application.CutCopyMode = False 'コピー切り取りを解除 wbSaki.Close False 'マスターデータ取り込み先のファイルを閉じる Else MsgBox "処理を中断します" End If Application.DisplayAlerts = True Dim ans As String ans = InputBox("見積書・請求書No", "", "") If ans <> "" Then wbMoto.Worksheets("見積").Range("I3").Value = ans Worksheets("見積").Range("I3").Value = "VHM-" & ans End If Application.DisplayAlerts = True ans = InputBox("見積書発行日", "", "") If ans <> "" Then wbMoto.Worksheets("見積").Range("F11").Value = ans End If ans = InputBox("完工日", "", "") If ans <> "" Then wbMoto.Worksheets("請求").Range("F11").Value = ans End If ans = InputBox("請求書発行日", "", "") If ans <> "" Then wbMoto.Worksheets("請求").Range("F12").Value = ans End If Worksheets(Array(2, 3)).Select ' 1 番目と 2 番目のシートを選択 Dim xFile xFile = Application.GetSaveAsFilename( _ FileFilter:="Excelファイル, *.xlsm") If TypeName(xFile) <> "Boolean" Then ActiveWorkbook.SaveAs FileName:=xFile End If Next End Sub

みんなの回答

  • kkkkkm
  • ベストアンサー率65% (1622/2462)
回答No.1

If fso.GetExtensionName Like "xls?" Then にたいするEnd IFがないのではないでしょうか

関連するQ&A

  • VBAでB3からLの最終入力までコピー仕方について

    現在、コピー元を"B3:L244"で指定していますが、 B3からL列の最後に書かれている範囲内でコピー出来る様にしたいのですが教えて頂けないでしょうか。 Private Sub CommandButton1_Click() Dim RC As Integer Dim OpenFileName, fileName, Path, SetFile As String Dim wbMoto, wbSaki As Workbook Set wbMoto = ActiveWorkbook 'マスターデータ取り込み元をセット Application.DisplayAlerts = False RC = MsgBox("マスターデータ取込みますか?", vbYesNo + vbQuestion, "確認") If RC = vbYes Then OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?") 'ダイアログボックスを表示して、マスターデータファイルを指定します。 If OpenFileName <> "False" Then SetFile = OpenFileName Else MsgBox "キャンセルされました" Exit Sub 'マスターデータの取り込みをキャンセル End If Workbooks.Open fileName:=SetFile, ReadOnly:=True, UpdateLinks:=0 'ダイアログボックスで指定したマスターデータファイルを開きます。 Set wbSaki = Workbooks.Open(Path & SetFile) 'ワークブック間のシート「項目」をコピーします。 wbSaki.Worksheets("Sheet1").Range("B3:L244").Copy wbMoto.Worksheets("1月").Range("B2").PasteSpecial xlPasteValuesAndNumberFormats Application.CutCopyMode = False 'コピー切り取りを解除 wbSaki.Close False 'マスターデータ取り込み先のファイルを閉じる Else MsgBox "処理を中断します" End If Application.DisplayAlerts = True End Sub

  • ExcelVBA シートコピー

    ExcelVBAで管理表1のシート1へ管理表2のシート2へコピーするVBAを書いてみました。 以下部分を修正したいです。 wbSaki.Worksheets("シート2").Range("A1:VA3000").Copy こちらの選択範囲を最終行と最終列という風にしたいのですが、うまくコピー貼り付けができないので理由がわかる方がいらっしゃれば教えていただけますでしょうか。 以下全体コード------------------ Sub 管理表1のシート1を管理表2のシート2へを貼り付け() '選択したファイルを取り込み、別のファイルに貼り付ける。 Dim RC As Integer Dim OpenFileName, fileName, Path, SetFile As String Dim wbMoto, wbSaki As Workbook Set wbMoto = ThisWorkbook 'マスターデータ取り込み元をセット Application.DisplayAlerts = False Application.ScreenUpdating = False 'BOOKを開かない RC = MsgBox("管理表1を開きますか?", vbYesNo + vbQuestion, "確認") If RC = vbYes Then 'サーバー指定 End Withまで With CreateObject("WScript.Shell") strCdir = CurDir .currentdirectory = "ファイル格納先" OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?") 'ダイアログボックスを表示して、マスターデータファイルを指定します。 If OpenFileName <> "False" Then SetFile = OpenFileName Else MsgBox "キャンセルされました" Exit Sub 'マスターデータの取り込みをキャンセル End If End With Workbooks.Open fileName:=SetFile, ReadOnly:=True, UpdateLinks:=0 'ダイアログボックスで指定したマスターデータファイルを開きます。 'VBA起動BOOKのシートをクリア wbMoto.Worksheets("シート1").Cells.Clear Set wbSaki = Workbooks.Open(Path & SetFile) '--- オートフィルタをクリアする ---' If wbSaki.Worksheets("シート2").FilterMode Then wbSaki.Worksheets("シート2").ShowAllData 'ワークブック間のシートをコピーします。 wbSaki.Worksheets("シート2").Range("A1:VA3000").Copy wbMoto.Worksheets("シート1").Range("A1").PasteSpecial xlPasteValues Application.CutCopyMode = False 'コピー切り取りを解除 wbSaki.Close False 'マスターデータ取り込み先のファイルを閉じる Application.ScreenUpdating = True 'BOOKを開かずに作業 Else MsgBox "処理を中断します" End If ThisWorkbook.Worksheets("元のシート").Select 'シート名を指定 Application.DisplayAlerts = True End Sub

  • vbaで正規表現

    正規表現のコードなんですが、 上手く動きません。 何故でしょうか… Sub Test() Dim reg As Object Dim ans As Object Dim c As Range         Set reg = CreateObject("VBScript.RegExp")     For Each c In Range("A1", Range("A" & Rows.Count).End(xlUp))             With reg             .Pattern = "^【[(1)-(20)](\d*/\d*)"             Set ans = .Execute(c.Value)         End With                 If ans > 0 Then             If Len(ans(0).submatches(0)) > 0 Then                             Debug.Print c.Address & "|" & ans(0).submatches(0)                             End If         End If             Next     End Sub

  • VBA CHANGEイベントに複数イベントを

    いつもお世話になっています。 色々しらべて試してみたんですが、うまくいかないんで教えてください。 CHANGEイベントに複数のイベントを書き込みたいんですが。 今現在、問題なく動いている以下のイベントがあります。 (1) Private Sub Worksheet_Change(ByVal Target As Range) Dim rang3 As Range Dim rang4 As Range Dim ■■ As String Dim LastRow1 As Long LastRow1 = Worksheets("○○").Cells(Rows.Count, "b").End(xlUp).Row Set rang4 = Worksheets("○○").Range("b:I" & LastRow) Set rang3 = Range("h4") If Intersect(Target, rang3) Is Nothing Then Exit Sub On Error Resume Next ■■ = WorksheetFunction.VLookup(Target.Value, rang4, 2, 0) If Err.Number > 0 Then MsgBox Target.Value & "はありません。基本情報台帳に入力してください。" Range("h4").Select Else Application.EnableEvents = False Range("I4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 2, False) Range("j4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 3, False) Range("k4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 7, False) Range("l4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 8, False) Range("m4").Value = Application.WorksheetFunction.VLookup(Target, Worksheets("△△").Range("b:I"), 5, False) Application.EnableEvents = True Range("K4").Select End If End Sub このシートにもう一つ、イベントを入れたいのですが。 (2) If Target.Count > 1 Then Exit Sub If Intersect(Target, Range("E4")) Is Nothing Then Exit Sub Else If Range("e4").Value = "1" Then Target.Offset(0, 19).Value = "☆" End If どこに入れればいいのかわかりません。 (3) また、(2)のイベントの他に、 (1)のVLOOLUPが実行され、尚且つ(2)のイベントのE4が値が1だった場合、Y4にH4の値を入れたいのですが・・・。 (2)のみなら動くことは確認できましたが、(1)のexit sub の直前に入れたり、end ifの前に入れたりしましたが、片方は動くが、もうひとつが動かないです。 (3)については、まったくわかりません。 マクロについて、自分でネットで勉強した程度なので、基本がわかっていないからなのでしょうが・・・。 どなたか、教えてください。 お願いします。

  • vbaにvlookupを組み込む

    お世話になります。 エクセルのマクロにvlookupを組み込みたいのですが,エラーが出てしまいます。 用意したものは「顧客名簿」というシートで,A列に顧客番号(6ケタの数字),B列に顧客名が入っています。C列以降はその他のデータが入っています。 「トップメニュー」というシートにあるマクロボタン「顧客抽出」を押すと,インプットボックスが現れます。これに顧客番号を入力すると,メッセージボックスが現れます。 この時のメッセージボックスに,インプットボックスに入力された番号により「顧客名簿」から顧客名を取り出し,「○○さんのデータを表示しますか」としたいのですが,ここでエラーが出ます。(○○は,「顧客名簿」のB列にある名前です) 実行時エラー 1004 WorksheetFunctionクラスのVLookupプロパティを取得できません。 組んであるマクロは以下の通りです。 Sub 顧客抽出() Dim ans As String, ans2 As String     ans = InputBox("顧客番号を入力", "入力", "")         If ans = "" Then             MsgBox "顧客番号が空白です" & vbNewLine & _                "処理を中止します", vbOKOnly         Else             If WorksheetFunction.CountIf(Worksheets("顧客名簿").Range("A1:B5000"), ans) = 0 Then                 MsgBox "顧客番号が登録されていません", vbOKOnly             Else                 ans2 = WorksheetFunction.VLookup(ans, Worksheets("顧客名簿").Range("A1:B5000"), 2, False)                 If MsgBox(ans2 & " さんのデータを表示しますか", vbYesNo) = vbYes Then                     Sheets("顧客情報").Select                     Range("D4").Value = ans                 Else                     MsgBox "処理を中止します", vbOKOnly                 End If             End If         End If End Sub 途中にある ans2 = WorksheetFunction.VLookup(ans, Worksheets("顧客名簿").Range("A1:B5000"), 2, False) の部分でエラーが出るのですが,解決策が見当たりません。 おそらくRange("A1:B5000")の部分に不具合があると思うのですが,どう対処すればいいでしょうか。 詳しい方,ご教授願います。

  • VBA マクロ処理時間の短縮について

    下記のコードを作りましたが、マクロを実行すると砂時計マークが表示されて、処理が終了するまでに30秒くらいかかります。 コードを変更して、マクロ処理時間を短縮する事はできないでしょうか? Sub A列のコピー() Dim rw2 As Long Dim rw1 As Long Dim newdate As Date With Worksheets("sheet1") rw2 = .cells(.Rows.Count, "c").End(xlUp).Row newdate = .Range("c" & rw2).value For rw1 = rw2 - 1 To 1 Step -1 If .Range("c" & rw1).value <> newdate Then Exit For Next rw1 .Range(.cells(rw1 + 1, 1), .cells(rw2, 1)).Copy Worksheets("sheet2").Range("v6").PasteSpecial xlValue If rw1 + 26 <= rw2 Then .Range(.cells(rw1 + 26, 1), .cells(rw2, 1)).Copy Worksheets("sheet2").Range("v40").PasteSpecial xlValue Application.CutCopyMode = False End If Application.CutCopyMode = False End With End Sub 各セルは、6000行くらいまで表示されています。  よろしくお願いします。

  • エクセル VBAについて。

    Private Sub ComboBox2_Change() On Error Resume Next With Me.ComboBox2 If .ListCount < 0 Then Exit Sub If .Value = "" Then Exit Sub Me.Range("K45").Value = _ Worksheets("マスタ").Range(.List(.ListIndex, 1)).Offset(0, 2).Value Me.Range("K48").Value = _ Worksheets("マスタ").Range(.List(.ListIndex, 1)).Offset(0, 4).Value End With End Sub これをマスタのU列とW列を表示したい場合、どこを変えれば良いのでしょうか? 今はD列とF列が表示されております。

  • VBAで別ブックからの貼付

    XP、EXCEL2007を使用しています。 元ファイル(A)からVBAで他のブック(B)を開き、A~CK列データをコピー後 ファイル(A)のA~CK列に貼り付けるコードを作りました。 しかし下記の★がついている2行がエラーでうまくいきません。 改善するにはどうすれば良いかご教授下さい。 色々調べながらくっつけたコードですので、 だいぶ問題があると思います。 エラーコードは 「オートーメーションエラーです。」 「致命的なエラーです。」 Sub DATEOPEN() Dim OpenFileName As Variant With CreateObject("WScript.Shell") .CurrentDirectory = "\\Landisk\disk\テスト\" End With OpenFileName = Application.GetOpenFilename("xlsファイル (*.xls),*.xls", 1, "ファイルを選択") If OpenFileName <> "False" Then If Trim(Dir(OpenFileName)) = "" Then Call MsgBox("ファイルが見つかりません", vbOKOnly, "確認") Else Workbooks.Open OpenFileName ★ActiveSheet.Range("A:CK").Copy _ ★ThisWorkbook.Worksheets("データ貼付").Range("A:CK") ActiveWorkbook.Close Range("A:CK").Select ActiveSheet.Paste ActiveWorkbook.Saved = True Application.CutCopyMode = False End If End If End Sub

  • 印刷後のVBAの実行 (3)

    Private Sub Workbook_BeforePrint(Cancel As Boolean) If ActiveSheet.Name = "Sheet1" Then If Range("D6").Value = "" Then Cancel = True MsgBox ("名前を入力してください") Range("D6").Select Exit Sub End If Else If ActiveSheet.Name = "Sheet2" Then If Range("C11").Value = "" Then Cancel = True MsgBox ("受付時間を入力してください") Range("C11").Select Exit Sub End If Else Exit Sub End If End If If Worksheets("Sheet1").Range("D5") = "不要" Then GoTo P1 ActiveSheet.Range("A70:Y70").Copy If Worksheets("Sheet3").Range("A1").Value = "" Then Worksheets("Sheet3").Range("A1").PasteSpecial Paste:=xlPasteValues Else Worksheets("Sheet3").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial _ Paste:=xlPasteValues End If Application.CutCopyMode = False P1: ActiveSheet.Range("A1").Select End Sub sheet1のD5に「不要」と入っていたら 24~33行目の作業がキャンセルになりますが sheet2のD5にも「不要」と入っていたら、同じ様にキャンセルできる様に出来ますでしょうか? ご回答お願いします

  • VBAについて

    こんばんは、下記のVBAについて質問をさせてください…! シートの名前と特定の列の名前が一致したらデータを引っ張ってくるというVBAなのですが、下記のVBAではもってくるデータはE列でおわりですが、もっと沢山列がある場合で、例えばDA列とかまである場合はどうすればよいのでしょうか…?! まさか「.Range("A" & cellCnt).~」というのを一つ一つ入力するわけではないと思うのですが、記述の方法が分からず困っています。 どなたかご教示いただけると大変助かります…! ' データをとってくるシートの行 Dim dataCnt As Integer ' 貼り付け先のシートの行 Dim cellCnt As Integer cellCnt = 1 For dataCnt = 1 To Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row If Sheets("Sheet1").Range("L" & dataCnt).Value = Sheets(sheetIdx).Name Then With Worksheets(sheetIdx) .Range("A" & cellCnt).Value = Worksheets("Sheet1").Range("A" & dataCnt).Value .Range("B" & cellCnt).Value = Worksheets("Sheet1").Range("B" & dataCnt).Value .Range("C" & cellCnt).Value = Worksheets("Sheet1").Range("C" & dataCnt).Value .Range("D" & cellCnt).Value = Worksheets("Sheet1").Range("D" & dataCnt).Value .Range("E" & cellCnt).Value = Worksheets("Sheet1").Range("E" & dataCnt).Value End With cellCnt = cellCnt + 1 End If Next