EXCEL VBAで月別シート分割の方法

このQ&Aのポイント
  • EXCEL VBAを使って月ごとに日付を分ける方法を教えてください
  • 職場で月合計をEXCELで1つのシートに出すことはできますが、それを日付ごとに複数のシートに分ける方法がわかりません
  • 月別シート分割のためにEXCEL VBAを使用する方法について教えてください
回答を見る
  • ベストアンサー

EXCEL VBA作成方法

職場で頭の痛いことがありまして・・・ 月合計をEXCELで1つのシートに出すことは出来ますが、それを日付ごとに(1日~31日)複数シートにする方法がわかりません。 内容は自分で工夫をして見ましたがうまくできません。ご教授をいただけますでしょうか? Sub 月別シート分割() Dim 元シート As Worksheet Dim 列幅() As Variant Dim 条件列 As Integer Dim 月 As Long Dim 条件1 As String, 条件2 As String Dim i As Integer, j As Long Set 元シート = ActiveSheet ActiveCell.CurrentRegion.Select ReDim 列幅(Selection.Columns.Count) For i = 1 To Selection.Columns.Count 列幅(i) = Selection.Cells(, i).ColumnWidth Next 条件列 = 1 月 = Month(ActiveCell.Offset(1, 条件列 - 1)) If Selection.AutoFilter Then Selection _ .AutoFilter For i = 1 To 31 Sheets.Add Before:=Sheets(i) ActiveSheet.Name = i & "" 条件1 = ">=" & DateSerial(月, i, 1) 条件2 = "<" & DateSerial(月, i + 1, 1) 元シート.Activate ActiveCell.CurrentRegion.Select Selection.AutoFilter Field:=条件列 _ , Criteria1:=条件1 _ , Operator:=xlAnd _ , Criteria2:=条件2 Selection.SpecialCells( _ xlCellTypeVisible).Copy Sheets(i).Range("A1").PasteSpecial For j = 1 To Selection.Columns.Count Sheets(i).Cells(, j).ColumnWidth _ = 列幅(j) Next j Next i Selection.AutoFilter Sheets(1).Activate End Sub

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

  • ベストアンサー
  • hige_082
  • ベストアンサー率50% (379/747)
回答No.2

オートフィルタの条件がうまく行ってないのかな? 並べ替えの後、1行ずつ処理した方が分りやすいような気がします Sub 月別シート分割() Dim i As Integer, j As Long With Worksheets("売上") .Range("a1").Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlGuess For j = 2 To .Range("a65536").End(xlUp).Row For i = 1 To Worksheets.Count If Format(.Cells(j, 1).Value, "yymmdd") = Worksheets(i).Name Then Exit For Next i If i = Worksheets.Count + 1 Then Worksheets.Add(, Worksheets(Worksheets.Count)).Name = Format(.Cells(j, 1).Value, "yymmdd") .Cells(1, 1).EntireRow.Copy Worksheets(Format(.Cells(j, 1).Value, "yymmdd")).Range("a1") End If .Cells(j, 1).EntireRow.Copy Worksheets(Format(.Cells(j, 1).Value, "yymmdd")).Range("a65536").End(xlUp).Offset(1) Next j End With End Sub 参考まで

HELPVBA
質問者

お礼

一度試してみます。

その他の回答 (1)

  • rivoisu
  • ベストアンサー率36% (97/264)
回答No.1

対象シートの構造とデータ例を示してください。 シート名についても説明をお願いします

HELPVBA
質問者

お礼

説明します。 一枚のシート(売上)シート名以下の内容です。 日付 商品名 単価 個数 金額 2008/1/10 りんご 500 100 50,000 2008/1/15 みかん 300 300 90,000 2008/1/20 バナナ 200 200 40,000 2008/1/10 りんご 500 100 50,000 自分としては(080110)のシート名 日付 商品名 単価 個数 金額 2008/1/10 りんご 500 100 50,000 2008/1/10 りんご 500 100 50,000 次は(080115)シート名 2008/1/15 みかん 300 300 90,000 といった内容で振り分けたいのです。

関連するQ&A

  • Excel VBAを使った重複行の抜き出しについて教えてください

    以下のような2シートから、重複する「商品番号」のあるsheet1の行を抜き出して、別シートに書き出したいと思っております。 sheet1  |  A   |  B   | C -+--------+-------+----- 1|      |      | -+--------+------+-------- 2|商品番号|商品名|責任者 -+--------+------+-------- 3|  123456|  ガム|山田太郎 -+--------+------+-------- 4| 2345678| チョコ|田中花子 ・・・ sheet2  |  A   |  B   | C -+--------+-------+----- 1|      |     | -+--------+------+-------- 2|商品番号|商品名|責任者 -+--------+------+-------- 3| 3987624|     | -+--------+------+-------- 4| 193678|      | ・・・ そこでVBAを作成したのですが、例えば商品番号「222011001」の行を抜き出したいのに、「22011001」の行も一緒に抜き出してしまいます。 どこがいけないのか、教えて頂けないでしょうか。 作成したVBAは以下の通りです。 VBA初心者で本を見ながら作ったため、大変見にくくなっているかと思います。申し訳ありませんが、どなたかおわかりになる方がいらっしゃいましたら、どうぞ宜しくお願い致します。 Option Base 1 Option Explicit Sub 重複データ抽出書き直し() Dim シート(2) As Worksheet Dim 比較列(2) As Integer Dim 一致セル As Range Dim 検索範囲 As Range Dim i As Integer Set シート(1) = Sheets("sheet1") Set シート(2) = Sheets("sheet2") 比較列(1) = 1: 比較列(2) = 1 シート(2).Activate ActiveCell.CurrentRegion.Select Selection.Offset(1, 比較列(2) - 1) _ .Resize(Selection.Rows.Count - 1, 1) _ .Select Set 検索範囲 = Selection Sheets.Add After:=Sheets(Sheets.Count) シート(1).Activate ActiveCell.CurrentRegion.Select Selection.Resize(1).Copy With Sheets(Sheets.Count).Range("A1") If Application.Version >= 9 Then .PasteSpecial 8 End If .PasteSpecial End With For i = 2 To Selection.Rows.Count Set 一致セル = 検索範囲.Find(Selection.Cells(i, 比較列(1)).Value) If Not 一致セル Is Nothing Then Selection.Offset(i - 1).Resize(1) _ .Copy Sheets(Sheets.Count) _ .Range("A65536").End(xlUp) _ .Offset(1) End If Next i Sheets(Sheets.Count).Activate End Sub

  • エクセルVBAの質問 開いているもう一つのブックのシート名をすべて取得する方法

    おはようございます。 現在マクロを実行しているブックのシート名を下のようなコードで取得していますが、これを 開いているもうひとつのブックのシート名を マクロ実行しているシート“しーと1”のJ3セル以降に並べる というように変更したいのですが、下のコードを少し変更して 対応できるでしょうか?教えていただけたら助かります。 Sub シート名() Dim i As Integer Dim mySheetCnt As Integer Dim mySheetNam As String Application.ScreenUpdating = False Columns("J:J").Select Selection.ClearContents Range("J2").Select ActiveCell.FormulaR1C1 = "項目名" mySheetCnt = ThisWorkbook.Sheets.Count For i = 2 To mySheetCnt mySheetNam = Sheets(i).Name Sheets("しーと1").Cells(i, 10) = mySheetNam Next i Application.ScreenUpdating = True MsgBox "シート名更新しました。" End Sub

  • マクロの記述をもっとシンプルにしたい

    このサイトでいただいた回答を利用し、また、マクロの記録を使って切り貼りして何とかやりたいことができるようになったマクロですが、記述に無駄があると思います。どのように書きかえるともっとスマートになるでしょうか。 作ったのは、190数名の数学と英語の点数を入力し、オートフィルタを使ってまず、数学の100点満点を取ったものを抽出します。そのリストをコピーし、隣のシートにコピーします。次に同じく数学ですが、60点未満のものを抽出し、それをコピーし、隣のシートのさっきコピーした隣にコピーします。それからオートフィルタを解除して、同じことを英語にも行います。最後に4つの表が並んだシートの不要な列を削除し、タイトルをつけ、列幅を調節し、オートフィルタを解除して終了します。 以下にマクロの記述をコピーします。まだなステイトメントばかりだと思いますので、アドバイスお願いいたします。 Sub 条件生徒抽出シンプル版new() Dim wS As Worksheet Set wS = Worksheets("Sheet2") wS.Cells.Clear With Range("A1").CurrentRegion .AutoFilter field:=5, Criteria1:=100 '数学の満点者を抽出 .Copy wS.Range("A1") '上のリストをコピー .AutoFilter field:=5, Criteria1:="<60" '数学の不合格者を抽出 .Copy wS.Range("h1") '上のリストをコピー Selection.AutoFilter '元データリストのオートフィルタを解除 .AutoFilter field:=6, Criteria1:=100 '英語の満点者を抽出 .Copy wS.Range("o1") '上のリストをコピー .AutoFilter field:=6, Criteria1:="<60" '英語の不合格者を抽出 .Copy wS.Range("v1") '上のリストをコピー End With Sheets("Sheet2").Select Range("A:A,F:F,H:H,M:M,O:O,S:S,V:V,Z:Z").Select Selection.Delete 'コピーした表の不要な列を削除 Rows("1:1").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 'タイトル行を追加 Range("A1").Select ActiveCell.FormulaR1C1 = "数学満点者" Range("F1").Select ActiveCell.FormulaR1C1 = "数学不合格者" Range("K1").Select ActiveCell.FormulaR1C1 = "英語満点者" Range("P1").Select ActiveCell.FormulaR1C1 = "英語不合格者" Rows("2:2").Select Selection.HorizontalAlignment = xlCenter '追加したタイトルをセンタリング Columns("A:A").ColumnWidth = 4.63 '各列の幅を変更 Columns("C:C").ColumnWidth = 12 Columns("C:C").ColumnWidth = 12.75 Columns("D:D").ColumnWidth = 6.38 Columns("F:F").ColumnWidth = 4.63 Columns("H:H").ColumnWidth = 12.75 Columns("I:I").ColumnWidth = 6.38 Columns("K:K").ColumnWidth = 4.63 Columns("M:M").ColumnWidth = 12.75 Columns("N:N").ColumnWidth = 6.38 Columns("P:P").ColumnWidth = 4.63 Columns("R:R").ColumnWidth = 12.75 Columns("S:S").ColumnWidth = 6.38 Sheets("今週の点数").Select Selection.AutoFilter 'オートフィルタを解除 End Sub

  • EXCEL VBA4行毎に枠で囲みたい

    お世話になります。 添付の様な表1があります。 これを表2のようにA1から順に4行毎に枠で囲みたいのです。 下記のようなコードを見よう見まねで書いてみましたがうまく動きません。 ごなたかご教授いただけませんでしょうか? よろしくお願い致します。 Dim i As Long Dim j As Long Dim lngYCnt As Long Dim intXCnt As Long Dim LastRow As Long ingYCnt = Worksheets("Sheet1").UsedRange.Rows.Count intXCnt = Worksheets("Sheet1").UsedRange.Columns.Count LastRow = Cells(Rows.Count, 1).End(xlUp).Row With Selection For i = 5 To LastRow Range("A" & i & ":F" & j).Select Selection.BorderAround Weight:=xlMedium j = j + 5 i = i + 5 Next End With どなたかご教授いただけませんでしょうか? よろしくお願い致します。 環境 EXCEL2003 WINDOWS XP SP3

  • エクセルVBAで列幅設定

    A列の幅を、C~F列の幅(同一ではありません)に設定しようと思いました。 ところが Columns("A").ColumnWidth = Range("C1:F1").Width とすると、ColumnWidthとWidthの単位がまったく違うのでエラーになります。 同じ単位で設定するには Columns("A").ColumnWidth = Columns("C").ColumnWidth + Columns("D").ColumnWidth + Columns("E").ColumnWidth + Columns("F").ColumnWidth とするか、 Sub test02() Dim c As Range Dim x As Single For Each c In Range("C1:F1") x = x + c.ColumnWidth Next Columns("A").ColumnWidth = x End Sub などのように手の込んだことをするしか思いつきません。 もっと簡単な方法はないでしょうか?

  • 左のセルと違った値だけを、他のセルに書き込む

    ワークシートの任意の「G列とH列」において、G列の値と違っていたら、 P列にその違った値だけを書き込む。 「違った値」の選択まではなんとかできましたが、それからがどうも進みません。 何卒ご教示お願い致します。 ------------ Sub tes1() Dim r As Range, base As Range Dim x, y Dim i Set r = Selection Set base = Selection.Cells(1, 1) x = r.Columns.Count y = r.Rows.Count Selection.RowDifferences(ActiveCell).Select ・ ・ --------------- G   H ・・・・P 98   94   98 101  101    91   95   91 69   69 71   71 99   95   99 89   89 94   94 67   67 68   64   68

  • エクセルのブックを開く度にシートの列幅を指定したいのですが・・・

    稚拙な質問お許しください。 エクセルでブックを開いたときに、すでにシートの列幅が任意の幅になっているよう、VBAで「ThisWorkbook」というところに、 Private Sub Workbook_Open() Sheet1.Columns("a:a").Select Selection.ColumnWidth = 7 Sheet1.Columns("b:b").Select Selection.ColumnWidth = 8 Sheet1.Columns("c:c").Select Selection.ColumnWidth = 10 Sheet1.Columns("e:e").Select end sub といった感じで記述したのですが、「F8」キーで処理の過程をみながら追っていくとどうしても、Eの列を過ぎるとEの列だけでなくそれ以降の列も選択してしまい(シート上に表があるのですが、その表の1番最後の列までです。)、任意の幅に指定できないのですが、原因がよくわかりません。どなたか、お力添えください。

  • Excel VBAについて教えて下さい。

    00というブックとテストというブックがあります。 00のデータを並び替え、一部変更し、テストのシート3へ貼付けを行いたいのですが、 うまく作動してくれません。以下に現在のコードを記載しましたので、ご指摘いただければと思います。 やりたいことは 1.ブック”00”のシート00にて条件がF列が0、E列がHでソートをかけます。 2.E列のHをすべて数字の1に変更します。 3.今度は別の条件、F列が1、E列がH、D列が1でソートをかけます。 4.E列のHをすべて消去します。 5.すべて表示させA列からE列までのデータを、テストのシート3へ貼付けをします。 コピー&ペーストは上手くいくのですが、肝心のソート+文字の変更+消去が出来ていません。 ネットを見ながら書いたコードで、VBAを勉強中です。 よろしくお願いします。 あと、この作業の前にブック00のB列にて昇順のソートをかけるというコードを追加したいのですが、 それについても教えていただけるとうれしいです。 よろしくお願い致します。 Private Sub Worksheet_Activate() Dim wb1 As Workbook Dim wb2 As Workbook Dim i As Long Application.ScreenUpdating = False Set wb1 = ActiveWorkbook Set wb2 = Workbooks.Open("C:\Documents and Settings\デスクトップ\メモ\00.xls", ReadOnly:=True) With wb2.Worksheets("00").Range("A1").CurrentRegion .AutoFilter .AutoFilter Field:=6, Criteria1:="=" & "0", Operator:=xlAnd .AutoFilter Field:=5, Criteria1:="=" & "H", Operator:=xlAnd .AutoFilter x = .Cells(Rows.Count, "A").End(xlUp).Row For i = 2 To x If Cells(i, 5) = "H" Then Cells(i, 5) = Replace(Cells(i, 5), "H", "1") End If Next i With wb2.Worksheets("00").Range("A1").CurrentRegion .AutoFilter .AutoFilter Field:=6, Criteria1:="=" & "0", Operator:=xlAnd .AutoFilter Field:=5, Criteria1:="=" & "H", Operator:=xlAnd .AutoFilter Field:=4, Criteria1:="=" & "1", Operator:=xlAnd .AutoFilter x = .Cells(Rows.Count, "A").End(xlUp).Row For i = 2 To x If Cells(i, 5) = "H" Then Cells(i, 5) = Replace(Cells(i, 5), "H", " ") End If Next i wb2.Sheets("00").Range("B1", .Cells(Rows.Count, 5).End(xlUp)).Copy wb1.Sheets("Sheet3").Range("K3").PasteSpecial wb2.Close False Range("A1").Select Application.ScreenUpdating = True End With End With End Sub

  • excelのマクロが上手く動作しません

    excel2013で、シートのレイアウトを整えるマクロを以下のように作成しました。 しかし、いざ他のシートで試すと、そのシートと同時に特定のシートにもなぜかマクロが実行されてしまいます。(恐らく作ったときに使っていたシート) どうしたら今見ているシートだけにマクロを実行することができるでしょうか? ActiveWindow.Zoom = 85 ActiveWindow.Zoom = 70 Columns("A:A").ColumnWidth = 10.13 Columns("A:A").ColumnWidth = 10.63 Columns("B:B").ColumnWidth = 6.63 Columns("D:D").ColumnWidth = 20 Columns("D:D").ColumnWidth = 23.75 Columns("D:D").ColumnWidth = 24.63 Columns("E:E").ColumnWidth = 10.38 Range("E1").Select ActiveCell.FormulaR1C1 = "インボイス金額" ActiveCell.Characters(7, 2).PhoneticCharacters = "キンガク" Columns("F:F").Select Selection.Delete Shift:=xlToLeft Columns("G:G").Select Selection.Delete Shift:=xlToLeft Range("H9").Select Columns("G:G").ColumnWidth = 11.38 Columns("I:K").Select Selection.Delete Shift:=xlToLeft Range("J9").Select Columns("I:I").ColumnWidth = 15 Columns("J:J").ColumnWidth = 9.75 Columns("K:K").ColumnWidth = 9.5 Range("L2").Select Columns("L:L").ColumnWidth = 5.5 Columns("O:O").Select Selection.Delete Shift:=xlToLeft Selection.ColumnWidth = 13.88 Columns("P:P").Select Selection.Delete Shift:=xlToLeft Selection.ColumnWidth = 12.13 Selection.ColumnWidth = 13.25 ActiveWindow.ScrollColumn = 2 ActiveWindow.ScrollColumn = 3 ActiveWindow.ScrollColumn = 4 ActiveWindow.ScrollColumn = 5 ActiveWindow.ScrollColumn = 6 ActiveWindow.ScrollColumn = 7 ActiveWindow.ScrollColumn = 8 ActiveWindow.ScrollColumn = 9 ActiveWindow.ScrollColumn = 10 ActiveWindow.ScrollColumn = 11 ActiveWindow.ScrollColumn = 12 Columns("Q:Q").Select Selection.ColumnWidth = 5.5 Columns("S:S").Select Selection.ColumnWidth = 6.75 Columns("T:T").ColumnWidth = 9.75 Columns("Q:T").Select Range("T1").Activate Selection.Style = "Comma [0]" Columns("U:U").Select Columns("V:V").ColumnWidth = 5.5 Columns("V:V").ColumnWidth = 6 Columns("W:Z").Select Selection.Delete Shift:=xlToLeft Columns("X:Z").Select Selection.Delete Shift:=xlToLeft Range("X10").Select Columns("X:X").ColumnWidth = 12.25 Columns("X:X").ColumnWidth = 11.13 Columns("Y:Y").ColumnWidth = 6.75 Columns("Z:Z").ColumnWidth = 11.63 Columns("AA:AA").ColumnWidth = 6.75 Columns("AB:AB").Select Selection.Delete Shift:=xlToLeft Range("AB2").Select Columns("AB:AB").ColumnWidth = 11 Columns("AD:AO").Select Selection.Delete Shift:=xlToLeft Range("AF14").Select Columns("AD:AD").ColumnWidth = 11 Columns("AE:AE").Select Selection.Delete Shift:=xlToLeft Range("AG7").Select Columns("AE:AE").ColumnWidth = 20.38 Columns("AF:AJ").Select Selection.Delete Shift:=xlToLeft ActiveWindow.ScrollColumn = 21 ActiveWindow.ScrollColumn = 1 Rows("2:2").Select ActiveWindow.FreezePanes = True Range("A2").Select ActiveWorkbook.Worksheets("11").Sort.SortFields.Clear ActiveWorkbook.Worksheets("11").Sort.SortFields.Add Key:=Range("D2:D137"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets("11").Sort.SortFields.Add Key:=Range("A2:A137"), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("11").Sort .SetRange Range("A1:AE137") .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .Apply End With End Sub よろしくお願い致します。

  • エクセルVBAについての質問です。

    エクセルVBAについての質問です。  動作環境は  OS:WINDOWS XP  エクセル2003  です。 今、Book1.xlsというエクセルファイルがあります。 このファイルの中に、【sheet1】,【sheet2】,【sheet3】の3つのシートが存在しています。 【sheet1】および【sheet2】には、A列=ユニーク番号、B列=データ1、C列=データ2・・・・n列=データnの値が約1500行(各行で、データの値は異なります。)入っています。 この【sheet1】と【sheet2】のデータの内容を照合して【sheet3】にその結果を反映(TRUEまたはFALSE)します。 仮に【sheet3】のあるセル(仮にD3)の値がTRUEとなったら、【sheet1】のセル(D3)の値を【sheet3】のセル(D3)に代入する。 逆に【sheet3】のあるセルの値がFALSEとなったら、そのセルはFLASEのままにする。プログラムは以下の様にしたのですが、全てを処理するまでに相当時間がかかっています。 VBAのプログラムは今回初めて書いたので、プログラムが悪いのか、プログラムの思想が悪いのかがわかりません。 どなたかご教授していただけませんか?多分、コードの書き方もキレイではないと思います(悲) Private Sub データ照合ボタン_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim i As Long Dim area As Range Dim A As Variant Dim WrkRange As String '----シート(1)とシート(2)の各セルの値を比較---- With Sheets("sheet1") WrkRow = .Cells(Rows.Count, 3).End(xlUp).Row End With Sheets("sheet3").Select For i = 12 To WrkRow WrkRange = Range("C" & i).Select ActiveCell.FormulaR1C1 = "=EXACT('sheet1'!RC,'sheet2'!RC)" WrkRange = Range("D" & i).Select ActiveCell.FormulaR1C1 = "=EXACT('sheet1'!RC,'sheet2'!RC)" '・           '・           '・ Next i A = i - 1 Sheets("sheet1").Select For i = 12 To A WrkRange = Range("C" & i).Select Selection.Copy Range("C" & i).PasteSpecial xlPasteValues Sheets("sheet3").Select If Range("C" & i) = True Then Sheets("sheet1").Select Range("C" & i).Copy Sheets("sheet3").Select Range("C" & i).Select ActiveSheet.Paste Else: End If Next i A = i - 1 Sheets("sheet1").Select For i = 12 To A WrkRange = Range("D" & i).Select Selection.Copy Range("D" & i).PasteSpecial xlPasteValues Sheets("sheet3").Select If Range("D" & i) = True Then Sheets("sheet1").Select Range("D" & i).Copy Sheets("sheet3").Select Range("D" & i).Select ActiveSheet.Paste Else: End If Next i          '・          '・          '・    End Sub

専門家に質問してみよう