セル空白時に月を変更した時の累計使用日数VBA２
- VBAを使用して、指定した条件に応じてセルの動作を制御するコードを作成したいです。
- 具体的には、以下の3つの条件を組み合わせたコードを作成したいです。 (1) B列の最終行が空白の場合、C1セルを変更した時にB9:B39を空白にする。 (2) B列が空白の場合、B9:B39の中に数値を入力するとその後の連続データが自動で表示される。 (3) B列の最終行に連続データが表示されている場合、C1セルを変更した後も変更前の連続データを継続させ、B9:B39に順番に連続データを表示させる。
- これらの条件を組み合わせた高度なVBAコードの作成方法について教えてください。
- ベストアンサー
セル空白時に月を変更した時の累計使用日数VBA２
以前質問したＶＢＡの事で再度質問があります。度々申し訳ありません。 Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, k As Long, myNum As Long, myMax As Long Dim myFlg As Boolean '←追加 If Intersect(Target, Range("C1,B9:B39")) Is Nothing Or Target.Count > 1 Then Exit Sub '最初にA列とB列の最終行の違いを取得しておく If Cells(Rows.Count, "A").End(xlUp).Row > Cells(Rows.Count, "B").End(xlUp).Row Then myFlg = True '←「TRUE」の場合はB列消去あり End If Application.EnableEvents = False If IsDate(Range("C1")) Then myMax = Day(DateSerial(Year(Range("C1")), Month(Range("C1")) + 1, 1) - 1) End If With Target If .Column = 3 Then Range("A9:A39").ClearContents For i = 1 To myMax Cells(i + 8, "A") = i Next i If myFlg = False Then '←「FALSE」（B列消去なし）の場合は・・・ myNum = Cells(40, "B").End(xlUp) Range("B9:B39").ClearContents For i = 1 To myMax Cells(i + 8, "B") = myNum + i Next i Else '「TRUE」（B列消去あり）の場合は・・・ Range("B9:B39").ClearContents End If Else k = .Row If .Value = "" Then Range(Cells(k, "B"), Cells(39, "B")).ClearContents ElseIf .Value = 0 Then Range(Cells(k + 1, "B"), Cells(myMax + 8, "B")) = 0 Else For i = k + 1 To myMax + 8 Cells(i, "B") = Cells(i - 1, "B") + 1 Next i End If End If End With Application.EnableEvents = True End Sub 内容はC1には年月（例えば２０１３年１２月）を表示させています。 (1)A列にC1セルの月の日付を1～月末まで自動表示させます。 (２)Ｂ列には連続データ（例えば１～３１）と入力しています。そしてＢ９～Ｂ３９どこかの数値を手で数値を変えると、その数値を変えた以降の数値の連続データが表示されます。 （３）Ｂ列の何処かの数値を空白にすると、その空白にした数値以降のセルも空白表示になります。 （４）Ｃ１セルの年月を変更するとＡ列の日付はＣ１セルに該当する年月の日付に自動変換され、Ｂ列は最終行から引き継いで連続データを表示する様になっています。 （５）Ｂ列の最終行が空白表示の場合にＣ１セルを変更するとＡ９～Ａ３９は該当する年月に変換しますが、Ｂ９：Ｂ３９は空白表示を継続して表示する様にします。 質問ですが、例えばB15を空白にするとB16：B39は空白状態になる様にVBAは仕事します。 その状態のままC1セルの年月を変更したらB9：B39は空白を表示させるVBAで質問をし一旦解決したと思いました。 しかしこのコードでＢ９：Ｂ３９に空白でなく、普通に連続データが表記されている状態でＣ１セルを変更してもＢ９：Ｂ３９が空白表示になってしまいます。 まとめますと・・・ (1)Ｂ列の最終行（２月は日付が２８日or２９日なのでＢ３６or３７、３０日が最終日の日付ならＢ３８、３１日の日付ならＢ３９）が空白表示の状態でＣ１セルを変更した時はＢ９：Ｂ３９は空白表示にする。 (2)Ｂ列が空白表示の時に、Ｂ９：Ｂ３９のどこかに数値を入力したら、その入力した数値以降の連続データが自動表記する。（例えばＢ２０に「５」と入力したらＢ２１に「６」Ｂ２２に「７」・・・と） (3)Ｂ列の最終行（２月は日付が２８日or２９日なのでＢ３６or３７、３０日が最終日の日付ならＢ３８、３１日の日付ならＢ３９）に連続データが表示されている場合でＣ１セルを変更した場合は変更前の連続データを継続させＢ９：Ｂ３９に順番に連続データを表示させる。（例えばＢ３９に「３１」と入力されている状態でＣ１セルを変更した場合Ｂ９に「３２」Ｂ１０に「３３」・・・と連続データを表記させる。） この３つの条件を高度に融合したコードは、どの様に組めば宜しいでしょうか？
- Excel（エクセル）
- 回答数2
- ありがとう数2
- みんなの回答 （2）
- 専門家の回答
質問者が選んだベストアンサー
No.1です。 ＞「Cells(i, "B") = Cells(Rows.Count, "A").End(xlUp) + i - 8」が黄色く表示されます。 Excel2003でも大丈夫のはずです。 エラーの行だけコードに手を加えてみました。 もう一度最初から載せてみます。 Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, k As Long, myNum As Long, myMax As Long Dim myFlg As Boolean '←追加 If Intersect(Target, Range("C1,B9:B39")) Is Nothing Or Target.Count > 1 Then Exit Sub '最初にA列とB列の最終行の違いを取得しておく If Cells(Rows.Count, "A").End(xlUp).Row > Cells(Rows.Count, "B").End(xlUp).Row Then myFlg = True '←「TRUE」の場合はB列消去あり End If Application.EnableEvents = False If IsDate(Range("C1")) Then myMax = Day(DateSerial(Year(Range("C1")), Month(Range("C1")) + 1, 1) - 1) End If With Target If .Column = 3 Then Range("A9:A39").ClearContents For i = 1 To myMax Cells(i + 8, "A") = i Next i If myFlg = False Then '←「FALSE」（B列消去なし）の場合は・・・ myNum = Cells(40, "B").End(xlUp) Range("B9:B39").ClearContents For i = 1 To myMax Cells(i + 8, "B") = myNum + i Next i Else '「TRUE」（B列消去あり）の場合は・・・ Range("B9:B39").ClearContents '★ここから追加 If WorksheetFunction.Count(Range("B9:B39")) = 0 Then For i = 9 To Cells(Rows.Count, "A").End(xlUp).Row Cells(i, "B") = Range("A9").End(xlDown) + i - 8 '※ ←少しいじってみました。 Next i End If End If '★ここまで Else k = .Row If .Value = "" Then Range(Cells(k, "B"), Cells(39, "B")).ClearContents ElseIf .Value = 0 Then Range(Cells(k + 1, "B"), Cells(myMax + 8, "B")) = 0 Else For i = k + 1 To myMax + 8 Cells(i, "B") = Cells(i - 1, "B") + 1 Next i End If End If End With Application.EnableEvents = True End Sub ※ シートモジュールのChangeイベントなどで一旦エラーが出てしまうと、そのSheetそのものが動かなくなることがありますので、 まっさらなSheetで試してみてください。 ご希望通りになれば良いのですが・・・m(_ _)m
その他の回答 (1)
- tom04
- ベストアンサー率49% (2537/5117)
こんばんは！ あっているかどうか判りませんが、前回のコードに少し手を加えてみました。 Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, k As Long, myNum As Long, myMax As Long Dim myFlg As Boolean '←追加 If Intersect(Target, Range("C1,B9:B39")) Is Nothing Or Target.Count > 1 Then Exit Sub '最初にA列とB列の最終行の違いを取得しておく If Cells(Rows.Count, "A").End(xlUp).Row > Cells(Rows.Count, "B").End(xlUp).Row Then myFlg = True '←「TRUE」の場合はB列消去あり End If Application.EnableEvents = False If IsDate(Range("C1")) Then myMax = Day(DateSerial(Year(Range("C1")), Month(Range("C1")) + 1, 1) - 1) End If With Target If .Column = 3 Then Range("A9:A39").ClearContents For i = 1 To myMax Cells(i + 8, "A") = i Next i If myFlg = False Then '←「FALSE」（B列消去なし）の場合は・・・ myNum = Cells(40, "B").End(xlUp) Range("B9:B39").ClearContents For i = 1 To myMax Cells(i + 8, "B") = myNum + i Next i Else '「TRUE」（B列消去あり）の場合は・・・ Range("B9:B39").ClearContents '★ここから追加 If WorksheetFunction.Count(Range("B9:B39")) = 0 Then For i = 9 To Cells(Rows.Count, "A").End(xlUp).Row Cells(i, "B") = Cells(Rows.Count, "A").End(xlUp) + i - 8 Next i End If End If '★ここまで Else k = .Row If .Value = "" Then Range(Cells(k, "B"), Cells(39, "B")).ClearContents ElseIf .Value = 0 Then Range(Cells(k + 1, "B"), Cells(myMax + 8, "B")) = 0 Else For i = k + 1 To myMax + 8 Cells(i, "B") = Cells(i - 1, "B") + 1 Next i End If End If End With Application.EnableEvents = True End Sub ※ コード内の★～★までを追加しています。 ご希望通りに動きにならなかったらごめんなさいね。m(_ _)m
お礼
問題が無事に解決出来ました！！ この度は長い間僕に付き合って下さり誠に感謝申し上げます。 これからも宜しくお願い申し上げます。
補足
お久しぶりです、僕の質問に長い間付き合っていただき誠にありがとうございます。勉強中ですが色々と忙しくてなかなか上手く出来ません。 コードを実際に試してＣ１セルの年月を変更したら「実行時エラー１３ 型が一致しません」と表記され「Cells(i, "B") = Cells(Rows.Count, "A").End(xlUp) + i - 8」が黄色く表示されます。 言い忘れていましたが僕のエクセルの種類はエクセル２００３を使用しているので何か不具合でもあるのでしょうか？
関連するQ&A
- セル空白時に月を変更した時の累計使用日数VBA
お世話になります、エクセルVBA初心者の者です。 '******************************************************************************* ' セル変更した時のイベント '******************************************************************************* Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, k As Long, myNum As Long If Intersect(Target, Range("C1,B9:B39")) Is Nothing Or Target.Count > 1 Then Exit Sub Application.EnableEvents = False With Target If .Column = 3 Then myNum = WorksheetFunction.Max(Range("B9:B39")) myDate = Range("C1").Value Range("A9:A39").ClearContents If IsDate(.Value) Then ' ----------A列に日にちを入力---------- For i = 1 To 31 If Month(myDate + i - 1) = Month(.Value) Then Cells(i + 8, "A").Value = Day(myDate + i - 1) Else Cells(i + 8, "A").Value = "" End If Next i ' ----------B列の空白条件---------- If Range("B39").Value = "" Or Range("B38").Value = "" Or Range("B37").Value = "" Or Range("B36").Value = "" Then Range("B9:B39").ClearContents Application.EnableEvents = True End End If ' ----------B列に連続値の入力---------- For i = 9 To 39 If Cells(i, "A").Value = "" Then Cells(i, "B").Value = "" Else Cells(i, "B") = myNum + i - 8 End If Next i End If Else End With Application.EnableEvents = True End Sub 内容はC1には年月（２０１３年１２月）を表示させています。 そして、B９～B39には累計使用日数を表示するVBAを組んでいます。 B9～B３９間に適当な数字を入力すると、連続データの数字が入力されるようになります。 そして、C1セルの日付を変更しても連続データが継続して表示されるVBAです。 B３９が空白表示の場合（小月ならB38で２月ならB36かB37）でC1セルの年月を変更した場合、連続データを表示させず空白セルを表示させるVBAを組んだつもりです。 しかし、上手く作動しません。もうお手上げです。どこがおかしいのでしょうか？ご教授宜しくお願いします。
- ベストアンサー
- Excel（エクセル）
- 空白セルと０値を識別させたい。（VBA）
すみません、誰か教えていただけますか。 シートの53、54、55行目にそれぞれ値入っています。 それを３行目にビジュアル的に表現させています。 55行目はセルの色で、53行目は数値があり同じ値が 続く部分の合計を出しています。 しかし、下記の記述ですと数値が0（変数D=0）の時に うまくいきません。空白セルと認識されてしまうと思います。 何か、良い方法があれば教えて頂けませんでしょうか。 宜しくお願いします。 Sub 表示() Dim a As Long Dim c As Long Dim D As Long Dim e As String Dim f As String c = 3 For a = 3 To 64 With Worksheets("Sheet1") If .Cells(53, a) <> .Cells(53, a + 1) Then .Range(.Cells(53, c), .Cells(53, a)).Select D = WorksheetFunction.Sum(Selection) e = D f = Selection(1).Offset(1, 0).Value G = Selection(1).Offset(2, 0).Value If D <> 0 Then Selection(1).Offset(-50, 0).Value = f + "//" + e .Range(.Cells(53, c), .Cells(53, a)).Offset(-50, 0).Select Selection.Interior.ColorIndex = G End If If Selection(1).Value = "" Then .Range(.Cells(53, c), .Cells(53, a)).Offset(-50, 0).Select Selection.ClearContents Selection.Interior.ColorIndex = xlNone End If c = a + 1 End If End With Next End Sub
- ベストアンサー
- オフィス系ソフト
- VBAエクセル空白セル0の入力
C列が空白となるまで、F列・・・L列の空白セルに0を代入する。 という処理を行いたく以下コードで実行をして ファイル種類をCSVにて、保存した後名前の変更で拡張子をTXTにすると データ入力された列の以降がカンマの羅列が「,,,,,,,,(改行)」の繰り返しで表示されてしまいます。 (CSV保存の後、視覚的に空白部分を行選択して削除するとなくなります。) どうすれば、このカンマが表示されなくなるでしょうか。 うまく説明できてないですが、アドバイス御願いします。 Dim i As Long i = 3 Do Until Cells(i, 3).Value = "" If Cells(i, 6).Value = "" Then Cells(i, 6).Value = "0" End If If Cells(i, 7).Value = "" Then Cells(i, 7).Value = "0" End If If Cells(i, 8).Value = "" Then Cells(i, 8).Value = "0" End If If Cells(i, 9).Value = "" Then Cells(i, 9).Value = "0" End If If Cells(i, 10).Value = "" Then Cells(i, 10).Value = "0" End If If Cells(i, 11).Value = "" Then Cells(i, 11).Value = "0" End If If Cells(i, 12).Value = "" Then Cells(i, 12).Value = "0" End If i = i + 1 Loop
- 締切済み
- Visual Basic
- 上のセルのコピーのマクロについて
下記コードで、B列（数値）の空白のセルにその上の値をコピーしているんですが、C列（日付）で行ったところ、できませんでした。 Integerが違うと思って変えたんですが、ほかにも関連して変えるところがありますか？？ 宜しくお願いいたします。 Sub 上のセルコピー() Dim i As Integer For i = 1 To Range("B" & Rows.Count).End(xlUp).Row If Cells(i, 2).Value = "" Then Cells(i, 2).Value = Cells(i - 1, 2).Value End If Next i End Sub
- ベストアンサー
- Visual Basic
- 連続データのVBAの質問
お世話になります。 Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, k As Long, myNum As Long If Range("C1") <= Date - Day(Date) Then Exit Sub If Not Intersect(Target, Range("C1,B9:B39")) Is Nothing And Target.Count = 1 Then Application.EnableEvents = False With Target If .Column = 3 Then myNum = WorksheetFunction.Max(Range("B9:B39")) If IsDate(.Value) Then For i = 9 To 39 If Cells(i, "A").Value = "" Then Cells(i, "B").Value = "" Else Cells(i, "B") = myNum + i - 8 End If Next i End If Else i = .Row If .Value = "" Then Range(Cells(i + 1, "B"), Cells(39, "B")).ClearContents Else For k = i + 1 To 39 If Cells(k, "A").Value = "" Then Cells(k, "B").Value = "" Else Cells(k, "B") = Cells(k - 1, "B") + 1 End If Next k End If End If End With Application.EnableEvents = True ElseIf Not Intersect(Target, Range("R8:R38")) Is Nothing Then Application.EnableEvents = False Range(Cells(Target.Row, 18), Cells(39, 18)).Value = Target.Value Application.EnableEvents = True End If End Sub これはセルC１に年月を表記させ、そのC1セルの年月を変更した場合B９～B３９のセルが自動で連続データの数字を記入し、B9～B39のどこかのセルを空白にすると、そのセル以降も空白になります。 そこで質問ですが、例えばB14の数字を消すとB１５～３９まで空白のセルになります。そして、B２０に１と入力するとB21～３９に連続データの数字が自動記入されます。 そしてC1の年月を次の月に更新した際は、B39で示された数字以降の連続データをB９に表示させるには、どうすれば良いでしょうか？
- ベストアンサー
- Excel（エクセル）
- 空白セルがある行の左寄せ操作の件
下記のようにＩ列に空白セルを検出し、その空白セルがある行においてＩ列からＭ列までのデータを左寄せする処理行っております。 For 番号 = 1 To Range("B1").End(xlDown).Row If Cells(番号, 9).Value = "" Then コピー開始列 = Cells(番号, 9).End(xlToRight).Column Range(Cells(番号, コピー開始列), Cells(番号,13)).Select Selection.Cut Destination:=Range(Cells(番号, 9),Cells(番号, 9 + 14 - コピー開始列)) Range(Cells(番号, コピー開始列), Cells(番号,13)).Select End If Next 番号 対象行数が３０００行ほどあり処理時間がかかりすぎるため、もう少し効率よいやり方があれば教えてください。
- ベストアンサー
- オフィス系ソフト
- 【Excel VBA】セルが塗りつぶされているものを探す方法を教えてください！
VBA初心者です。 お分かりになる方がいらっしゃったら、教えてください。 プロシージャを書いていただけると本当にありがたいです！ 次のようなデータがあって、セルが赤く塗りつぶされているものがあれば、「データが間違っています」、なければ「OKです！」とメッセージボックスを表示したいのですが、どのようにすればよいかわかりません。 A B C D 1 No.1 完了(赤) りんご 2 No.2 受付 みかん 3 No.3 完了 みかん ○ ちなみに、B1のセルを塗りつぶすのは、 その前に、B列が"完了"でD列が""空白のものを検索し、赤く塗りつぶす構文を入れています。 Dim myData as integer myData=Range("B1000").End(xlUp).Row For i = myData To 2 Step -1 If Cells(i, 2).Value = "完了" And Cells(i, 4).Value = "" Then Cells(i, 2).Interior.Color = vbRed End If Next i この後にメッセージボックスが出るようにしたいです！ よろしくお願いいたします。
- ベストアンサー
- その他MS Office製品
- Excelで入力したセルの隣のセルに累計の表示を
無理難題を押し付けられて困っています。 画像のように、セルＢ3に入力し、その累計を隣のセルＣ3に表示させたいのです。 以下、Ｂ4～Ｂ6も同じです。 同様のことをD⇔E、F⇔G、H⇔I、J⇔K・・・・でも行いたいのです。 ここの質問欄を検索し、以下のVBAを見つけました Const inpColumn = "C" '入力する列名が『A』列の場合 Private Sub Worksheet_Change(ByVal Target As Excel.Range) With Target '単一セルに入力した場合 If .Count = 1 Then '入力する列名に入力した場合 If .Column = Range(inpColumn & "1").Column Then '入力が数値の場合 If IsNumeric(.Value) Then '隣の列『B列』の値に入力した値を加える '（Offsetの２番目の1が１つ右のB列を示す） .Offset(0, 1) = .Offset(0, 1) + .Value End If End If End If End With End Sub これを実行したところ、B⇔Cだけが実行され、他の列では駄目でした。 VBAに無知なもので、どこを直せばよいのか全く分かりません。 また、他の方法があるのかも分かりません。 説明不足かも知れませんが、よろしくお願いいたします。
- ベストアンサー
- ノートPC
- VBA A1セルが空白になったら隣のセルも空白に
いつもお世話になります。 WINDOWS7 EXCELL2010 です。 A1セルに文字列で５桁のID番号を入力するとI4のセルに今日の日付が入るようにマクロを作っています。 このときA1セルをキーボードのBacksPaceでID番号を消してエンターキーを押した時にI4セルも空白にしたいと考えて下記のように作りましたが If Range("A1") = “” Range("$I$4") = "0000/00/00" Else Range("$I$4").ClearContents 上の構文が上手くゆかず困り果てました。 どのようにすればいいか御指導願えませんでしょうか。 参考に Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$A$1" Then Range("I4").Value = Date If Range("A1") = “” Range("$I$4") = "0000/00/00" Else Range("$I$4").ClearContents End Sub
- ベストアンサー
- Excel（エクセル）
- エクセルマクロ 【空白セルを無視する方法を教えてください】
マクロを独学で学び仕事に応用しているのですが、どうしても分からないことが発生してしまい、質問です。 内容は、今、エクセルシートのA1～B5の範囲で A B 1 1 1 2 1 2 3 4 1 5 1 という形で入力されています(見難くてスミマセン)。 この状態から「A列とB列に同じ数字が入力されてれば、メッセージBOXを表示して、なおかつOKボタンを押したら該当セルを赤くする」というマクロを作りたいのですが、本来であれば1行目のみ赤くなるはずなのですが、空白セルが含まれている3行目も赤くなってしまうんです。つまり、空白セルも「同じ値」と認識されているみたいなのですが...。 この場合、空白セルを無視するにはどうしたらよいのですか？教えてください。なお、マクロは以下のように作っています。 Sub ナンバーチェック() Dim Btn As Integer For X = 5 To 10 If Cells(X, "A").Value = Cells(X, "B").Value Then Btn = MsgBox("同じ数値です", vbOK, "警告") If Btn = vbOK Then Cells(X, "A").Interior.ColorIndex = 3 Cells(X, "B").Interior.ColorIndex = 3 End If End If Next End Sub
- ベストアンサー
- オフィス系ソフト
お礼
問題が無事に解決出来ました！！ この度は長い間僕に付き合って下さり誠に感謝申し上げます。 これからも宜しくお願い申し上げます。