Excel 2010でVBAを使用して特定の月に収入を増やす方法
- Excel 2010を使用してVBAを学びましたが、次に特定の月に収入を増やす方法を知りたいです。
- 前回教えて頂いたVBAコードをもとに、月ごとに収入を増やす方法を実装したいです。
- 具体的には、４月、７月、１０月、１月に収入を１００００００ずつ増やしたいです。ご教授頂けますか？
- ベストアンサー
エクセル２０１０を使用しています。
前回VBAについてご教授頂きました。 Private Sub Workbook_Open() 'この行から With Worksheets("Sheet1") If .Range("I20") <> Date Then .Range("H20") = .Range("H20") + 4000000 * ((Year(Date) - Year(.Range("I20"))) * 12 + Month(Date) - Month(.Range("I20"))) .Range("I20") = Date End If End With End Sub 'この行まで ここまで教えて頂きました。 一つ出来ると、別の欲が沸いてくるもので、次は、特定の月（４月、７月、１０月、１月）に１００００００ずつ増やしていきたいです。 度々申し訳ございませんが、ご教授頂きたいです。
- 104_AZ
- お礼率80% (4/5)
- その他（学問・教育）
- 回答数1
- ありがとう数7
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
- ベストアンサー
> 一つ出来ると、別の欲が沸いてくるもので、次は、特定の月（４月、７月、１０月、１月）に１００００００ずつ増やしていきたいです。 あまりにも正直な気持ちを書かれているのに免じて、これにも回答しましょう。 以下のコードを.Range("I19")をDateに置換して使用してください。 .Range("I19")としたのはバグがないか確認用に使用しました。 Private Sub Workbook_Open() 'この行から With Worksheets("Sheet1") Dim diff As Integer ' 前回から今月までの経過月数 diff = (Year(.Range("I19")) - Year(.Range("I20"))) * 12 + Month(.Range("I19")) - Month(.Range("I20")) If diff > 0 Then ' 前回から一月以上経過したか？ ' 前回の翌月から今月までにあった1,4,7,10月をカウント Dim n As Integer Select Case Month(.Range("I20")) Mod 3 Case 0: n = (diff + 2) \ 3 Case 1: n = diff \ 3 Case 2: n = (diff + 1) \ 3 End Select ' 数値の更新 .Range("H20") = .Range("H20") + n * 1000000 End If .Range("I20") = .Range("I19") ' 前回の日付を更新 End With End Sub 'この行まで 次は、ご自分で少し試行錯誤をしてから質問し、質問には自分で試してみたのは何か、どこが分からないのかを記載しましょう。 そうすれば次の質問にも、私を含めみなさん快く回答するかと思います。
関連するQ&A
- Excelでシート名と最終更新日を自動表示したい
Excelを使って （１）セルA1に入れた名目をシート名にし （２）セルH1には、最終更新日を自動で入れたいです。 調べた結果、 シート名を右クリックして「コードの表示」から （１）は Private Sub Worksheet_Change(ByVal Target As Range) Sheets(1).Name = Range("B1") End Sub を入れてうまくいきましたが、 （２）は Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If ThisWorkbook.Saved = False Then Worksheets("Sheet1").Range("H1").Value = Date End If End Sub を入れてみましたが（←調べましたもの） うまくいきませんでした。 単純に、 Private Sub Worksheet_Change(ByVal Target As Range) Sheets(1).Name = Range("B1") End Sub Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If ThisWorkbook.Saved = False Then Worksheets("Sheet1").Range("H1").Value = Date End If End Sub とつなげて入れるのではだめなんでしょうか？ それとも、（２）の何かが間違っていますか？ ご教授願います。
- ベストアンサー
- その他MS Office製品
- エクセルVBAについて
エクセルVBA初心者で、勉強中の者です。 添付画像のような時間のグラフのようなものを作りたいと思っています。 ～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～ Sub 時間グラフ作成() If Worksheets("(1)(1)(1)(1)(1)").Range("F2").Value = CDate("9:05") Then Worksheets("(2)(2)(2)(2)").Range("I2").Select With Selection.Interior .ColorIndex = 8 .Pattern = xlSolid End With Elseif Worksheets("(1)(1)(1)(1)(1)").Range("F2").Value = CDate("9:10") Then Worksheets("(2)(2)(2)(2)").Range("J2").Select With Selection.Interior .ColorIndex = 8 .Pattern = xlSolid End With ・ ・ ・ End If End Sub 'それから、終了の時間を入れて、開始から終了までの間を塗りつぶす。 ～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～ 以上のように作成しようと考えていましたが、いざやろうとすると 1行に対してあまりにも膨大な記述をしなくてはならないことに 気がつきました(一月分ともなると恐ろしいです・・・)・・・。 もっと効率的な方法はあるものでしょうか？ よろしくお願いいたします。
- ベストアンサー
- その他（プログラミング・開発）
- EXCEL マクロ
お世話になります。 マクロは初心者です。 セルの数値を参照して、シートをアクティブにしたいのですが 下記のような繰り返しでシートが30ぐらいあるので、簡単な 表現に出来ないでしょうか。 宜しくお願いします。 Private Sub Workbook_Open() If 0 <= Worksheets(4).Range("M1") < 7 Then Worksheets(4).Activate End If If 0 <= Worksheets(5).Range("M1") < 7 Then Worksheets(5).Activate End If If 0 <= Worksheets(6).Range("M1") < 7 Then Worksheets(6).Activate End If If 0 <= Worksheets(7).Range("M1") < 7 Then Worksheets(7).Activate End If If 0 <= Worksheets(8).Range("M1") < 7 Then Worksheets(8).Activate End If If 0 <= Worksheets(9).Range("M1") < 7 Then Worksheets(9).Activate End If End Sub
- ベストアンサー
- その他MS Office製品
- セルの選択ができません。
windws7 Excel2007でマクロ作成中の初心者です。 B列に８月21日から９月20日まで入力されてます。 以下のコードでセルＢＷ28の数値によりセル選択範囲が異なります。 すべて８月２１日の行から開始します。 28のときは、８月２１日の行から２８番目の行まで選択 29のときは、８月２１日の行から２９番目の行まで選択 30のときは、８月２１日の行から３０番目の行まで選択 以上正常にセルの選択が出来ます。 しかし３１のとき ８月２１日の行ただ１行しか選択してくれません。 上の例のように ８月２１日の行から３１番目の行、つまり９月２０日までの行まで 選択したいのですが、どうしたらよいでしょうか。 Sub sersu sentaku() If Range("BW28") = 28 Then Range("B30").Resize(Day(DateSerial(Year(Date), Month(Date), 28)), 66).Select ElseIf Range("BW28") = 29 Then Range("B30").Resize(Day(DateSerial(Year(Date), Month(Date), 29)), 66).Select ElseIf Range("BW28") = 30 Then Range("B30").Resize(Day(DateSerial(Year(Date), Month(Date), 30)), 66).Select ElseIf Range("BW28") = 31 Then Range("B30").Resize(Day(DateSerial(Year(Date), Month(Date), 31)), 66).Select End If End Sub
- ベストアンサー
- Visual Basic
- エクセルマクロ実行時エラー1004について
システムを起動すると実行時エラー1004とでて5行目のWorksheets(3).Selectで止まってしまいます。 私が作成したものではなく、なぜなのかわかりません。緊急を要しています。誰かわかる方いらっしゃらないでしょうか。 よろしくお願いします。 Dim Max_data2 As Integer Public Cunt_01 As Integer Sub auto_open() Dim wkSheet As Excel.Worksheet Worksheets(3).Select ' Range("c4") = Date ' Range("c20") = Date Range("d6").Select With Worksheets("工場、受注一覧表") ' Worksheets("工場、出荷指示書").Range("j3").Value = Date ' Worksheets("工場、出荷指示書").Range("I4").Value = Date ' Worksheets("工場、出荷指示書").Range("J4").Value = Time .Range("d5").Value = Date .Range("d21").Value = Date .Range("d23").Value = Date End With For Each wkSheet In ThisWorkbook.Worksheets If InStr(wkSheet.Name, "工場、出荷指示書") <> 0 Or InStr(wkSheet.Name, "@") <> 0 Then wkSheet.Range("J3").Value = Date wkSheet.Range("I4").Value = Date wkSheet.Range("J4").Value = Time End If Next Call com_list Cunt_01 = 10 '１件づつ転記のカウンタ '★追加★ '入出庫報告書のファイルを開く Dim sPath As String sPath = ThisWorkbook.Worksheets("工場、受注一覧表").Range("W1").Value If sPath = "" Then Exit Sub End If If Dir(sPath) <> "" Then Workbooks.Open (sPath) End If ThisWorkbook.Activate ''★23.06.12 ActiveWindow.SmallScroll ToRight:=4 End Sub
- 締切済み
- オフィス系ソフト
- VBAでオーバーフローが出て困っています（エクセル2000です）
自動売買ロボット作成マニュアルという本のなかに株価をダウンロードするためのプログラムとしてソースが書かれているのですが、オーバーフローとなってしまい、実行できません。lastrow = (Range("B4").End(xlDown).Row + 1)のところでオーバーフローを起こします。この文章だけでは対処できないと思いますのでプログラムを写します。 恐れ入りますが、お助けください。 Sub Calc() Dim code As String Dim data_length As Integer, date_temp As Date Dim day_s As Integer, month_s As Integer, year_s As Integer Dim day_e As Integer, month_e As Integer, year_e As Integer Dim row_length As Integer code = input_temp(2) data_length = -100 date_temp = DateAdd("d", data_length, Now) day_e = Day(Now) month_e = Month(Now) year_e = Year(Now) day_s = Day(date_temp) month_s = Month(date_temp) year_s = Year(date_temp) Range("B4:R65000").ClearContents For i = 0 To Abs(data_length) * 0.65 Step 50 If i = 0 Then lastrow = "4" For wtbl = 19 To 25 url = "URL;http://table.yahoo.co.jp/t?s=" & code & "&a=" & month_s & "&b=" & day_s & "&c=" & year_s & "&d=" & month_e & "&e=" & day_e & "&f=" & year_e & "&g=d&q=t&y=" & i & "&z=" & code & "&x=.csv" Call Get_Data If Range("B4") = "日付" Then Exit For Else Range("B4:H54").ClearContents End If Next Else url = "URL;http://table.yahoo.co.jp/t?s=" & code & "&a=" & month_s & "&b=" & day_s & "&c=" & year_s & "&d=" & month_e & "&e=" & day_e & "&f=" & year_e & "&g=d&q=t&y=" & i & "&z=" & code & "&x=.csv" lastrow = (Range("B4").End(xlDown).Row + 1) Call Get_Data Range("B" & lastrow, "H" & lastrow).Delete row_length = (Range("B4").End(xlDown).Row) If row_length - lastrow < 49 Then Exit For End If End If Next Range("B5:H65000").Sort Key1:=Range("B5") lastrow = Range("B4").End(xlDown).Row Range("B5", "B" & lastrow).NumberFormatLocal = "yyyy/mm/dd" Range("C5", "H" & lastrow).NumberFormatLocal = "0" Range("A1").Select End Sub Sub Get_Data() With ActiveSheet.QueryTables.Add(Connection:=url, Destination:=Cells(lastrow, 2)) .Name = "Yahoo" .FieldNames = False .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = True .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = False .RefreshPeriod = 0 .WebSelectionType = xlSpecifiedTables .WebFormatting = xlWebFormattingNone .WebTables = wtbl .WebPreFormattedTextToColumns = True .WebConsecutiveDelimitersAsOne = True .WebSingleBlockTextImport = False .WebDisableDateRecognition = False .Refresh BackgroundQuery:=False End With End Sub
- 締切済み
- その他（プログラミング・開発）
- エクセル２０１０でマクロが動きません
こんにちは。 マクロ超初心者です。 頑張ってエクセル２０１６でマクロ作成しましたが、エクセル２０１０で途中から動かず…。 何が悪いんでしょうか… ここから動きません…と書いたところから動きません(涙) Private Sub シート編集_Click() Application.ScreenUpdating = False Dim i Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim Sh4 As Worksheet Set Sh1 = Worksheets("あ") Set Sh2 = Worksheets("い") Set Sh4 = Worksheets("う") Dim dayCutoff As Date dayCutoff = Application.InputBox("年月日を入力してください", "お支払期限 年月日を入力", Format(Date, "yyyy/mm/dd")) Sh4.Range("D12").Value = DateSerial(Year(dayCutoff), Month(dayCutoff) + 2, 0) 'お支払期限 dayCutoff = Application.InputBox("年月日を入力してください", "請求書発行 日を入力", Format(Date, "yyyy/mm/dd")) Sh4.Range("AC3").Value = Format(Date, "yyyy/mm/dd") '発行日 Sh1.Cells.Clear With Sh1 'edit .Range("A2") = "番号" .Range("B2") = "会社名" .Range("C2") = "判定" .Range("D2") = "契約番号" .Range("E2") = "拠点" .Range("F2") = "税率" .Range("G2") = "月額(税抜)" .Range("H2") = "消費税" .Range("I2") = "月額(税込)" .Range("J2") = "今回" .Range("K2") = "全回" .Range("L2") = "店番" ここから動きません………… For i = 3 To Sh2.Cells(.Rows.Count, 1).End(xlUp).Row .Cells(i, 1) = Sh2.Cells(i, 2) .Cells(i, 2) = Sh2.Cells(i, 4) .Cells(i, 4) = Sh2.Cells(i, 3) .Cells(i, 5) = Sh2.Cells(i, 4) & "(" & Sh2.Cells(i, 6) & ")" .Cells(i, 6) = Sh2.Cells(i, 9) & "%課税" .Cells(i, 7) = Sh2.Cells(i, 8) .Cells(i, 8) = Sh2.Cells(i, 10) .Cells(i, 9) = Sh2.Cells(i, 11) .Cells(i, 10) = Sh2.Cells(i, 12) .Cells(i, 11) = Sh2.Cells(i, 7) .Cells(i, 12) = Sh2.Cells(i, 2) If Sh1.Cells(i, 10) > Sh1.Cells(i, 11) Then .Cells(i, 3) = "×" Else .Cells(i, 3) = "〇" End If If Sh1.Cells(i, 3) = "×" Then .Cells(i, 2) = "" End If Next i End With '空白行を削除 Dim j As Integer, myFlag As Boolean Dim c As Range With Worksheets("edit").Range("A2").CurrentRegion For j = .Rows.Count To 2 Step -1 myFlag = False For Each c In .Cells(j, 2) If c.Value <> "" Then myFlag = True Exit For End If Next If myFlag = False Then .Rows(j).Delete End If Next End With MsgBox "データの転記が終わりました" End Sub
- 締切済み
- Visual Basic
- エクセルのVBAで質問があります。
現在自分はカレンダーを作成していて、カレンダーに祝日を入れたいと思っています そこで これを if文もしくはselectcase どっちを使ったら楽か教えてもらいたいです Sub MakeCalendar(hi As Date) Dim i As Integer 'カレンダーにセットする日付 Dim g As Integer '日付をセットする行番号 Dim r As Integer '日付をセットする列番号 Dim lastDay As Integer '作成するカレンダーの月末 g = 2 'その月の開始曜日を算出 r = Weekday(DateSerial(Year(hi), Month(hi), 1), vbSunday) '指定された日付の翌月１日をもとて、日付の前の日を計算する lastDay = Day(DateSerial(Year(hi), Month(hi) + 1, 1) - 1) For i = 1 To lastDay 'iに日付の設定 Cells(g, r).Value = i If r = 7 Then r = 1 '戻して g = g + 1 '1行下に書く Else r = r + 1 '１列→に移動する End If Next End Sub Sub test() Range("A2:G7").Value = "" 'A2～G2にカレンダー表示 MakeCalendar Range("I2").Value 'I2に日付を入力する End Sub Sub test() Range("A2:G7").Value = "" 'A2～G2にカレンダー表示 MakeCalendar Range("I2").Value 'I2に日付を入力する End Sub このようなマクロを組んでいまして、祝日（ゴールデンウィークなど)を赤で塗りつぶすような物を考えています。 VBAは初心者でまだあまりわかっていないので、ご教授ください
- 締切済み
- 情報工学
- このコードの修正点はありますか？
Private Sub Clear() With Worksheets("abc") With .Range("A2", .Range("A" & Rows.Count).End(xlUp)) If .Row = 2 Then .EntireRow.Resize(, 7).ClearContents End If End With End With End Sub シートabcの、A2から最終行まで取得。 A2からA15までデータがあれば、それらの行のG列までクリア。 というコードですが、 If .Row = 2 Thenというのは、2行ならという意味ではないのですか？ 1行でもデータがあればクリアにしてもらいたいのですが、 If .Row > 0 Thenみたいな感じにならないのでしょうか？ 教えていただいたコードですが、この部分がわからないです。 ご教授くださいませ。
- ベストアンサー
- オフィス系ソフト
- エクセル 最終行からの連続コピー
* すぐに回答を！ エクセルC20からI51までデータを１日１行ずつ入力します。 データが入力されている最終行から上に連続する１０行（最終行含む）をコピーしたいのですが、最終行から10行上をどのように認識させたらいいのか、わかりません。Offsetなど試してみましたがダメでした。 よろしくお願いします。 Sub dataコピー() Dim i As Long Dim j As Integer Dim rng As Range '最後尾から10行前までを選択 With Worksheets("月").Range(Cells(20, 3), Cells(51, 10)) For i = Cells(Rows.Count, 1).End(xlUp).Row To -10? If rng Is Nothing Then Set rng = .Rows(i) End If j = j + 1 If j >= 10 Then Exit For Next i 'コピー If Not rng Is Nothing Then rng.Copy Range("M1") Beep Else MsgBox "該当行は存在しません。", 48 End If End With Set rng = Nothing End Sub コードはこちらを参考にしました http://questionbox.jp.msn.com/qa5440189.html
- 締切済み
- オフィス系ソフト
お礼
有難うございました！お陰様で理想的になりました。次回からは仰る通り自分で解決出来るように努力します。それでもわからない場合はまたお願いします。