こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

セル空白時に月を変更した時の累計使用日数VBA2

以前質問した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には年月(例えば2013年12月)を表示させています。

(1)A列にC1セルの月の日付を1~月末まで自動表示させます。

(2)B列には連続データ(例えば1~31)と入力しています。そしてB9~B39どこかの数値を手で数値を変えると、その数値を変えた以降の数値の連続データが表示されます。

(3)B列の何処かの数値を空白にすると、その空白にした数値以降のセルも空白表示になります。

(4)C1セルの年月を変更するとA列の日付はC1セルに該当する年月の日付に自動変換され、B列は最終行から引き継いで連続データを表示する様になっています。

(5)B列の最終行が空白表示の場合にC1セルを変更するとA9~A39は該当する年月に変換しますが、B9:B39は空白表示を継続して表示する様にします。

質問ですが、例えばB15を空白にするとB16:B39は空白状態になる様にVBAは仕事します。
その状態のままC1セルの年月を変更したらB9:B39は空白を表示させるVBAで質問をし一旦解決したと思いました。

しかしこのコードでB9:B39に空白でなく、普通に連続データが表記されている状態でC1セルを変更してもB9:B39が空白表示になってしまいます。

まとめますと・・・

(1)B列の最終行(2月は日付が28日or29日なのでB36or37、30日が最終日の日付ならB38、31日の日付ならB39)が空白表示の状態でC1セルを変更した時はB9:B39は空白表示にする。

(2)B列が空白表示の時に、B9:B39のどこかに数値を入力したら、その入力した数値以降の連続データが自動表記する。(例えばB20に「5」と入力したらB21に「6」B22に「7」・・・と)

(3)B列の最終行(2月は日付が28日or29日なのでB36or37、30日が最終日の日付ならB38、31日の日付ならB39)に連続データが表示されている場合でC1セルを変更した場合は変更前の連続データを継続させB9:B39に順番に連続データを表示させる。(例えばB39に「31」と入力されている状態でC1セルを変更した場合B9に「32」B10に「33」・・・と連続データを表記させる。)

この3つの条件を高度に融合したコードは、どの様に組めば宜しいでしょうか?

投稿日時 - 2014-08-10 12:09:37

QNo.8711381

すぐに回答ほしいです

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

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

投稿日時 - 2014-08-11 19:25:09

お礼

問題が無事に解決出来ました!!

この度は長い間僕に付き合って下さり誠に感謝申し上げます。

これからも宜しくお願い申し上げます。

投稿日時 - 2014-08-16 19:56:46

ANo.2

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.1

こんばんは!

あっているかどうか判りませんが、前回のコードに少し手を加えてみました。

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

投稿日時 - 2014-08-10 21:27:31

補足

お久しぶりです、僕の質問に長い間付き合っていただき誠にありがとうございます。勉強中ですが色々と忙しくてなかなか上手く出来ません。

コードを実際に試してC1セルの年月を変更したら「実行時エラー13 型が一致しません」と表記され「Cells(i, "B") = Cells(Rows.Count, "A").End(xlUp) + i - 8」が黄色く表示されます。

言い忘れていましたが僕のエクセルの種類はエクセル2003を使用しているので何か不具合でもあるのでしょうか?

投稿日時 - 2014-08-11 02:43:00

お礼

問題が無事に解決出来ました!!

この度は長い間僕に付き合って下さり誠に感謝申し上げます。

これからも宜しくお願い申し上げます。

投稿日時 - 2014-08-16 19:56:59

あなたにオススメの質問