• 締切済み

Excel2007 VBAについて

Excel2007 VBAについて質問です。 現在マクロでExcelデータを毎朝8時に保存フォルダに自動保存しているのですが、今回保存フォルダの中に年別フォルダ、月別フォルダを作成しその中に保存していきたいと思っています。 例 2013年フォルダの中に1月～12月のフォルダ 2013年2月25日の保存データは2013年フォルダ内の2月フォルダ内に保存。 ちなみに年度別フォルダは、2030年ぐらい迄作る予定です。 以下現在のマクロです。 Sub 自動保存（） Dim 年 As String Dim 月 As String Dim 日 As String 年 ＝ Year（Now（）） 月 ＝ Month（Now（）） 日 ＝ Day （Now（）） With Workbooks （″サンプル．xlsm″） WorkSheets（″Sheet3″）．Range（″B6：B205″）．Value ＝ Worksheets（″メインモニタ″）．Range（″F13：F212″）．Value End With Worksheets（″Sheet3″）．Select Worksheets（″Sheet3″）．Copy Application．DisplayAlerts ＝ False Const mypath As String ＝ ″C：￥保存データ￥″ With ActiveWorkbook．SaveAs″C：￥保存データ￥″＿＆年＆″年″＆月＆″月″＆日＆″日″＆″．xlsx″．Close End With Application．DisplayAlerts ＝ True Application．Ontime DeteValue（Dete ＋1）＋TimeValue（″8:00:00″），″自動保存″ Worksheets（″メインモニタ″）．Activate End Sub すいませんがご指導願います。

みんなの回答

noname#203218
noname#203218
回答No.1

ファイルを保存する前に、フォルダ「保存データ」に年フォルダ、月フォルダがあるか検索し、無ければフォルダを新設する。 年、月、日はＮＯＷ関数を用いる事を条件とする。で宜しいでしょうか。 尚、変数に漢字を使用されていますが、変数とテキストデータが重複すると見づらいので、変数をアルファベットとしました。 Sub 自動保存（） Dim SaveFol, Fname As String Dim nen, tuki, nichi As String nen = Year(Now()) tuki = Month(Now()) nichi = Day(Now()) With Workbooks （″サンプル．xlsm″） WorkSheets（″Sheet3″）．Range（″B6：B205″）．Value ＝ Worksheets（″メインモニタ″）．Range（″F13：F212″）．Value End With Worksheets（″Sheet3″）．Select Application．DisplayAlerts ＝ False '－－－－－－－－－－－－－－－－－－－－－－－ 'ここから追加 '年フォルダ確認、無ければ年フォルダ作成 SaveFol = "C:\保存データ\" & nen & "年" If Dir(SaveFol, vbDirectory) = "" Then MkDir SaveFol End If '月フォルダ確認、無ければ月フォルダ作成 SaveFol = "C:\保存データ\" & nen & "年\" & tuki & "月" If Dir(SaveFol, vbDirectory) = "" Then MkDir SaveFol End If Fname = "\＿" & nen & "年" & tuki & "月" & nichi & "日.xlsx" ActiveWorkbook.SaveAs SaveFol & Fname ActiveWorkbook.Close '－－－－－－－－－－－－－－－－－－－－－－－ 'ここまで Application．DisplayAlerts ＝ True Application．Ontime DeteValue（Dete ＋1）＋TimeValue（″8:00:00″），″自動保存″ Worksheets（″メインモニタ″）．Activate End Sub 不要と思われる箇所は削除しましたので、必要でしたら再度追加下さい。 ペースト先が記載していないのでコピー削除。Worksheets（″Sheet3″）．Selectも不要な気がしますが。 Worksheets（″Sheet3″）．Copy パスを使用していないので削除しています。 Const mypath As String ＝ ″C：￥保存データ￥″ 日付保存ファイル名の先頭に全角の＿を入れてますが、それで良いのでしょうか？問題なければ良いのですが。 ファイル名、フォルダ名の作り方が希望通りであるかは分かりませんので、ダミーのフォルダでも作成して確認下さい。

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

関連するQ&A

  • 選択されているシートを移動したい

    一定ではない複数のシートがあり、 そのうちの右端の１枚は必ず「ファイル集計」というシートになっています。 この、ファイル集計以外のシートを 新しいブックを作って移動させるにはどうしたらいいでしょうか。 あくまでもファイル集計は元のブックに残し それ以外のシートを移動させたいのです。 Sub 入力データを保存して閉じる() Dim ファイルナンバー As String Dim 保存指定フォルダ2 As String Dim mySht As Worksheet With Application .DisplayAlerts = False For Each mySht In Worksheets If mySht.Name <> Sheets("ファイル集計").Name Then mySht.Select False Next .DisplayAlerts = False End With ↑このようなかたちで、選択するところまでは出来たのですが それを新しいブックに移動させるのがうまくいきません。 ChDir "C:\計算\" & 保存指定フォルダ Activesheets.Move ActiveWorkbook.SaveAs Filename:=ファイルナンバー & "D.xls" Application.DisplayAlerts = False 　　ActiveWorkbook.Close end sub とすると、選択されているシートのうち１枚しか移動できないのです。 教えてください。

  • VBAについて

    VBAについて質問です。 データをコピーして新規ブックとして名前（年、月、日）をつけて別のフォルダ（デスクトップ上のフォルダ）に毎朝8時に保存したいのですが、Cディスク内に直接保存されてしまいます。 コードは以下の通りです。 Sub 自動保存() With workbooks("サンプル.xism") Worksheets("Sheet3").Range("B6:B205").Value = .Worksheets("メインモニタ").Range("F13:F212").Value Worksheets("Sheet3").Range("D6:D205").Value = .Worksheets("メインモニタ").Range("K13:K212").Value Worksheets("Sheet3").Range("F6:F205").Value = .Worksheets("メインモニタ").Range("P13:P212").Value Worksheets("Sheet3").Range("H6:H205").Value = .Worksheets("メインモニタ").Range("U13:U212").Value End With Worksheets("Sheet3").Select Worksheets("Sheet3").Copy Application.DisplayAlerts = False With ActiveWorkbook.SaveAs "C:\サンプル2_" & Format(Date , "yyyymmdd") . Close End With Application.DisplayAlerts = True Application.OnTime DateValue(Date + 1) + TimeValue("8:00:00") , "自動保存" Worksheets("メインモニタ")　. Activate End Sub ご教授宜しくお願いします。

  • EXCEL2000とEXCEL2003のVBAについて

    現在、EXCEL2000で下記のコードを実行しています。 が、EXCEL2003で実行すると、 .UsedRange.Copy myb のコードが実行されているのにコピー出来ていません。 ファイルは開いていて、エラーは出ていないのです。 問題点わかる方教えていただけますか？ Sub 日別データ読込() Dim rngsaki As Range Dim pathmacrobook As String Dim namebook As String Dim motobook As Workbook Dim myb As Variant Set rngsaki = Workbooks("残高集計用.xls").Worksheets(3).Range("a2") pathmacrobook = ThisWorkbook.Path & "\CSV読込データ12\" namebook = Dir(pathmacrobook & "*.xls") Do While Not namebook = "" Set motobook = Workbooks.Open(pathmacrobook & namebook) Set myb = Workbooks("残高集計用.xls").Worksheets(3).Range("A65536").End(xlUp) With motobook.Worksheets("Sheet1") .UsedRange.Copy myb End With motobook.Close False namebook = Dir() Loop MsgBox "完了しました" End Sub

  • エクセルVBAが途中で止まります

    以前別のカテゴリで質問したのですが、そちらでは解決出来なかったので、こちらで改めて質問します。 下記のマクロで、一つのブックからSheet1だけをコピーして来て、少し処理をし、元のブックを閉じるというもので、ブックの数は多くて3000程、少ない時は300位です。 で、このマクロだと９００位までですと最後まで行くのですが、それを超えるとリストが９５位で止まってしまいます。 自宅で別データを作ってやってみるとうまくいきました。 コピー元のブックにはテキストデータのみで、２００文字から５００文字程度の大きさしかありません。 ファイル名も５０文字程度の物を全部２０文字程度まで短くしてもみましたが、ダメでした。 どうかお知恵をお貸しください。 Sub ★1★ブックの結合() Dim sFile As String Dim sWB As Workbook, dWB As Workbook, aWB As Workbook Dim dSheetCount As Long Dim i As Long Dim SOURCE_DIR As String 'エクセルデータに変換されたファイルのあるフォルダを選択します。 MsgBox "エクセルに変換されたデータのフォルダを選択" With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then SOURCE_DIR = .SelectedItems(1) & "\" End If End With Application.ScreenUpdating = False '指定したフォルダ内にあるブックのファイル名を取得 sFile = Dir(SOURCE_DIR & "*.xls") 'フォルダ内にブックが無ければ終了 If sFile = "" Then Exit Sub '集約用ブックを作成 Set dWB = Workbooks.Add '転記マクロの中のDMリストシートをコピーする Workbooks("転記用マクロ.xlsm").Worksheets("DMリスト").Copy Before:=dWB.Worksheets("Sheet1") Application.DisplayAlerts = False Worksheets(Array("Sheet1", "sheet2", "sheet3")).Select ActiveWindow.SelectedSheets.Delete Application.DisplayAlerts = True '集約用ブック作成時のシート数を取得 dSheetCount = dWB.Worksheets.Count Do 'コピー元のブックを開く Set sWB = Workbooks.Open(Filename:=SOURCE_DIR & sFile) 'コピー元のsheet1を集約用ブックにコピー sWB.Worksheets("sheet1").Copy After:=dWB.Worksheets(dWB.Sheets.Count) シート転記 'コピー元ファイルを閉じる Application.DisplayAlerts = False sWB.Close Application.DisplayAlerts = True 'セルA2の名前を変更する 'シート名をセルA2の値に変更 'ActiveSheet.Name = Range("A2").Value '次のブックのファイル名を取得 sFile = Dir() Loop While sFile <> "" '集約用ブックを保存する 'dWB.SaveAs Filename:=DEST_FILE Application.ScreenUpdating = False End Sub

  • EXCEL2011 Objectに入れたWork…

    お世話になります。 どうも よく、解らない の、ですが 下記で コメントアウト、させている ラインの、内 ＊印を、付けている どの行、をも コメントアウトから、戻すと ☆で、添付映像の エラーに、なります コメントアウトの、ままだと エラーには、なりません 察するに Wsが ActiveSheetで、無いと with　Ws に、対する .Range(cells(… が、嫌っぽい の、ですが こんな事、当たり前 なのか 疑問、なのです お教え下さい。 　　　　記 Option　Explicit Option　Base　0 Dim　Data(100,　100)　As　Long,　Ch　As　Long,　s1　As　Long,　s2　As　Long,　Ws　As　Worksheet,　すとり　As　Range Sub　testMain()　'　簡易テスト Dim　現状保存　As　Worksheet,　シート名　As　String 　Let　シート名　=　ActiveSheet.Name Application.ScreenUpdating　=　False 　Worksheets(シート名).Copy　after:=Worksheets(Worksheets.Count)　　'■ 　Set　現状保存　=　ActiveSheet　　　　　　　　　　　　　　　　　　　　　　　　　　　　'■ 　Set　Ws　=　Worksheets.Add() '　Worksheets(シート名).Copy　after:=Worksheets(Worksheets.Count)　　'＊□ '　Set　現状保存　=　ActiveSheet　　　　　　　　　　　　　　　　　　　　　　’□ '　Worksheets(シート名).Select　　　　　　　　　　　　　　　　　　　　'＊ 　現状保存.Visible　=　False '　Ws.Visible　=　False　　　　　　　　　　　　　　　　　　　　　　　'＊ Application.ScreenUpdating　=　True 　Call　ダミーデータ作成 　Call　testC 　Call　testV 　Call　testE Application.DisplayAlerts　=　False 現状保存.Delete Ws.Delete Application.DisplayAlerts　=　True End　Sub Sub　ダミーデータ作成() 　With　Ws.Range("a1:cv100") 　　.Formula　=　"=RANDBETWEEN(1,10000)" 　　.Calculate 　　.Value　=　.Value 　End　With 　Let　Ws.Cells(1,　101).Formula　=　"=MIN("　&　Ws.Name　&　"!"　&　Ws.Range("a1:cv100").Address　&　")" 　Ws.Cells(1,　101).Calculate 　For　s2　=　1　To　100 　　For　s1　=　1　To　100 　　　Data(s1,　s2)　=　Ws.Cells(s1,　s2).Value 　　Next　s1 　Next　s2 　Let　Data(0,　0)　=　Ws.Cells(1,　101).Value End　Sub Sub　testC() 　Ch　=　10000 　With　Ws 　　For　s2　=　1　To　100 　　　For　s1　=　1　To　100 　　　　If　Ch　>　.Cells(s1,　s2).Value　Then　Ch　=　.Cells(s1,　s2).Value 　　　Next 　　Next 　End　With End　Sub Sub　testV() 　Ch　=　10000 　　For　s2　=　1　To　100 　　　For　s1　=　1　To　100 　　　　If　Ch　>　Data(s1,　s2)　Then　Ch　=　Data(s1,　s2) 　　　Next 　　Next End　Sub Sub　testE() 　With　Ws 　　すとり　=　.Range(Cells(1,　1))　　　　　　　　　　　　　　　　　'☆ 　End　With End　Sub (※注:□の2行を　コメントから　外す、時は　 同、■の2行を　コメントアウトして、下さい) 　　　　　　　　　　　　　　　　　　　　　　以上

  • VBAがうまく動きません。

    エクセルVBAで実行時は正確に動かないが、ステップインでは正常に作動するのはなぜですか？ 入力シートに入力された情報を元にデータシートから抽出を行い、新規シートを開き、そこでリストにしたい情報のみを編集（不要なタイトル行などの削除）して、自動で貼り付けと名前の定義を行うマクロを作っています。 ステップイン[F8]や実行[F5]では正常に作動するのですが、実際に使用してみると、抽出データが貼り付けされていない状態(セルは空白)となりますが、名前の定義は抽出データと同じ行まで定義されているので、貼り付けのみ上手くいっていないように思われます。 下記が作成したコードです。情報が足りないようでしたら、申し訳ありません。 お手上げ状態となっていますので、お力添えいただけると幸いです。 Dim syurui as String Dim suuryou as Integer Dim target as Range Private Sub Worksheet_Change(ByVal target As Range) If Intersect(target, Range("D7")) Is Nothing Then Exit Sub Else Call 抜出 End If End Sub Sub 抜出() Worksheets("データ").Activate ’後に出てくる名前初期化でエラーを防ぐため仮定義 ActiveWorkbook.Names.Add Name:="番号", _ RefersTo:=Worksheets("データ").Range("K2") syurui = Worksheets("入力").Range("D9").Value Worksheets("データ").Select Set target = Worksheets("データ").Range("M2") With Worksheets("データ").Range("D1") .AutoFilter field:=4, Criteria1:=syurui .CurrentRegion.SpecialCells(xlVisible).Copy With Worksheets.Add .Paste ’不要な行を削除 .Rows(1).Delete .Range("A:D").Delete .Range("B:F").Delete ’抽出した情報を貼り付け＆新規シート削除 .UsedRange.Copy target Application.DisplayAlerts = False .Delete Application.DisplayAlerts = True End With .AutoFilter End With ’抽出データの最終行を調べる suuryou = Worksheets("データ").Cells(65536, "M").End(xlUp).Row If suuryou = 1 Then Worksheets("入力").Activate Exit Sub Else Range("番号").Name.Delete ActiveWorkbook.Names.Add Name:="番号", _ RefersTo:=Worksheets(”データ").Range("M2:M" & suuryou) End If Worksheets("入力").Activate End Sub

  • 【VBA】指定月のオートフィルタを作るには？

    当方Excel2003です。 あるブックの中にシートが一つ（シート名はsheet1）あり、そのシートの中にはB2セルを起点とするデータリストがあります。 （データリストの列はB列→名前、C列→金額、D列→日付とし、日付の表示はyyyy/mm/dd、行は約400行ほどあります。） 現在、データリストのD列にマクロのオートフィルターを使用し、任意の年月の月始めから月末までのデータを抽出しようとして、以下の構文を作成中なのですが、 datStart = DateSerial("i", "j", 1) の部分でエラーが出てしまい、「型が一致しません」と表示されてしまいます。 どういうふうに変更したら良いのか、またそもそも全体の構成がおかしい等の問題点があればその解決策をどなたかご教示いただければ幸いです。 よろしくお願いいたします。 Sub 指定月抽出() Dim i, j As Integer Dim datStart As Date Dim datEnd As Date Dim strSDate As String Dim strEDate As String i = Application.InputBox("年を入力してください。", Type:=1) j = Application.InputBox("月を入力してください。", Type:=1) If i = False Or j = False Then Exit Sub Application.ScreenUpdating = False Application.DisplayAlerts = False If Worksheets("sheet1").AutoFilterMode Then Worksheets("sheet1").AutoFilterMode = False End If datStart = DateSerial("i", "j", 1) datEnd = DateAdd("m", 1, datStart) strSDate = ">=" & Format(datStart, "yyyy/m/d") strEDate = ">=" & Format(datEnd, "yyyy/m/d") With ThisWorkbook.Worksheets("DATA") .Range("B2:D" & Range("D65532").End(xlUp).Row).Select .AutoFilter Field:=3, _ Criteria1:=strSDate, _ Operator:=xlAnd, _ Criteria2:=strEDate End With Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

  • VBA　同じ場所に保存する

    部署ごとに分割し、ブックで保存するコードです。 保存場所がデスクトップになっています。 これを同じ場所に保存する方法をお知らせください。 よろしくお願いします。 Sub macro1() Dim w As Worksheet Dim n As Long Dim r As Long Dim s As String Dim WSH As Variant Dim myPath As String Set w = ActiveSheet n = Worksheets.Count Application.ScreenUpdating = False On Error GoTo errhandle For r = 2 To w.Range("A65536").End(xlUp).Row s = w.Cells(r, "A") w.Rows(r).Copy Worksheets(s).Range("A65536").End(xlUp).Offset(1) Next r On Error GoTo 0 Set WSH = CreateObject("Wscript.Shell") myPath = WSH.specialfolders("Desktop") & "\" For r = Worksheets.Count To n + 1 Step -1 Worksheets(Worksheets.Count).Copy ActiveSheet.Columns.AutoFit ActiveWorkbook.SaveAs Filename:=myPath & ActiveSheet.Name ActiveWorkbook.Close False Application.DisplayAlerts = False Worksheets(Worksheets.Count).Delete Application.DisplayAlerts = True Next r w.Select Exit Sub errhandle: Worksheets.Add after:=Worksheets(Worksheets.Count) ActiveSheet.Name = s w.Rows(1).Copy Range("A1") Resume Application.ScreenUpdating = True End Sub

  • VBAで複数シートをまとめたい

    VBAを作るのは今回が初めてで行き詰ってしまいました。 フォルダ内の「.xlsx」４つのファイルのSheet1(４つともSheet1です) を統合.xLsmの1月シートのb2～値でコーピー貼り付けを行いたいのですが、 下記のものでやっていけば出来のかなと思ってますが、ご教授お願い致します。 Private Sub CommandButton1_Click() Dim sFile As String Dim sWB As Workbook, dWB As Workbook Dim dSheetCount As Long Dim i As Long Dim c As Long Dim ws As Worksheet Debug.Print (ws.Index) Const SOURCE_DIR As String = "C:\Users\KWEUSER\Desktop\data\" Application.ScreenUpdating = False '指定したフォルダ内にあるブックのファイル名を取得 For c = 1 To 4 sFile = Dir(SOURCE_DIR & "*.xlsx") 'フォルダ内にブックがなければ終了 If sFile = "" Then Exit Sub '集約用ブックを作成 Set dWB = Workbooks.Add '集約用ブック作成時のシート数を取得 dSheetCount = dWB.Worksheets.Count Do 'コピー元のブックを開く Set sWB = Workbooks.Open(Filename:=SOURCE_DIR & sFile) 'コピー元の　c (1,2,3,4,5)シートを集約用ブックにコピー sWB.Worksheets(c).Copy After:=dWB.Worksheets(dSheetCount) 'シート名をファイル名に ActiveSheet.Name = sFile 'コピー元ファイルを閉じる sWB.Close '次のブックのファイル名を取得 sFile = Dir() Loop While sFile <> "" '集約用ブック作成時にあったシートを削除 Application.DisplayAlerts = False For i = dSheetCount To 1 Step -1 dWB.Worksheets(i).Delete Next i Application.DisplayAlerts = True '集約用ブックを保存して閉じる dWB.SaveAs Filename:="C:\Users\KWEUSER\Desktop\data\" & c & ".xlsx" dWB.Close Next Application.ScreenUpdating = False End Sub

  • EXCEL2011 Objectに入れたWoｒ…改

    お世話になります。 どうも なんと言って 良いのか 本当に、済みません スレットを、変えよう と、して 念の、ため 確認に、再度 走らせて、みた の、ですが コメントアウト、させていても ☆で、添付映像の エラーに、なります もう頭が ？？？？？？ です 兎に角 エラー理由が、解りません 申し訳、ありませんが お教え下さい。 　　　　記 Option　Explicit Option　Base　0 Dim　Data(100,　100)　As　Long,　Ch　As　Long,　s1　As　Long,　s2　As　Long,　Ws　As　Worksheet,　ランゲ　As　Range Sub　testMain()　'　簡易テスト Dim　現状保存　As　Worksheet,　シート名　As　String 　Let　シート名　=　ActiveSheet.Name Application.ScreenUpdating　=　False 　Worksheets(シート名).Copy　after:=Worksheets(Worksheets.Count)　　'■ 　Set　現状保存　=　ActiveSheet　　　　　　　　　　　　　　　　　　　　　　　　　　　　'■ 　Set　Ws　=　Worksheets.Add() '　Worksheets(シート名).Copy　after:=Worksheets(Worksheets.Count)　　'＊□ '　Set　現状保存　=　ActiveSheet　　　　　　　　　　　　　　　　　　　　　　’□ '　Worksheets(シート名).Select　　　　　　　　　　　　　　　　　　　　'＊ 　現状保存.Visible　=　False '　Ws.Visible　=　False　　　　　　　　　　　　　　　　　　　　　　　'＊ Application.ScreenUpdating　=　True 　Call　ダミーデータ作成 　Call　testC 　Call　testV 　Call　testE Application.DisplayAlerts　=　False 現状保存.Delete Ws.Delete Application.DisplayAlerts　=　True End　Sub Sub　ダミーデータ作成() 　With　Ws.Range("a1:cv100") 　　.Formula　=　"=RANDBETWEEN(1,10000)" 　　.Calculate 　　.Value　=　.Value 　End　With 　Let　Ws.Cells(1,　101).Formula　=　"=MIN("　&　Ws.Name　&　"!"　&　Ws.Range("a1:cv100").Address　&　")" 　Ws.Cells(1,　101).Calculate 　For　s2　=　1　To　100 　　For　s1　=　1　To　100 　　　Data(s1,　s2)　=　Ws.Cells(s1,　s2).Value 　　Next　s1 　Next　s2 　Let　Data(0,　0)　=　Ws.Cells(1,　101).Value End　Sub Sub　testC() 　Ch　=　10000 　With　Ws 　　For　s2　=　1　To　100 　　　For　s1　=　1　To　100 　　　　If　Ch　>　.Cells(s1,　s2).Value　Then　Ch　=　.Cells(s1,　s2).Value 　　　Next 　　Next 　End　With End　Sub Sub　testV() 　Ch　=　10000 　　For　s2　=　1　To　100 　　　For　s1　=　1　To　100 　　　　If　Ch　>　Data(s1,　s2)　Then　Ch　=　Data(s1,　s2) 　　　Next 　　Next End　Sub Sub　testE() 　With　Ws 　　Set　ランゲ　=　.Range(Cells(1,　1))　　　　　　　　　　　　　　　'☆ 　End　With End　Sub (※注:□の2行を　コメントから　外す、時は　 同、■の2行を　コメントアウトして、下さい) 　　　　　　　　　　　　　　　　　　　　　　以上

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

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

質問する