FC2ブログ

スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

Excel VBA をやってみた その2 


 ABCDE
1開始日2012/04/01   
2終了日2012/04/30   
3日数30   
4     
5     

という基本となるものがあります。
開始日 <= 終了日 で、日数 > 0 の規則があるとします。

処理列は限定せず1~3行に入力した時点で自動的に計算結果を埋め込みたい。

例えば、
C1 に開始日を埋めただけでは計算できないので、
その後、C2 なり C3 を埋めた時点で空いているところを自動算出したい。
埋められる順の規則はなく、
C2 → C3 / C3 → C2 なら C1
C1 → C3 / C3 → C1 なら C2
C1 → C2 / C2 → C1 なら C3
また、すべて埋まった状態での変更では、C1 / C2 なら C3 を C3 なら C2 を求め直す。

・その部分が削除されたら計算はしない
 (C列全てが埋まっていたとして C1 を削除しても C2 / C3 から C1 を求め直すことはしない)
・開始日 <= 終了日 でない場合、 日数 は空白に
・開始日があって日数を変更した時、日数 <= 0 なら 終了日 を空白に
と、勝手に追加

Worksheet_Change を使ってみました。
2007 で確認していたのですが、いろいろな動作を確認できて収穫が多かったです。
 
まず、以下を記述してみました
Private Sub Worksheet_Change(ByVal Target As Range)
  Static iCol As Long
  Dim t As Range
  Dim vDt1 As Variant, vDt2 As Variant, vDt3 As Variant

  If (iCol <> 0) Then Exit Sub

  For Each t In Target
    iCol = t.Column
    vDt1 = Empty: vDt2 = Empty: vDt3 = Empty
    If (IsDate(Cells(1, iCol))) Then vDt1 = CDate(Cells(1, iCol))
    If (IsDate(Cells(2, iCol))) Then vDt2 = CDate(Cells(2, iCol))
    If (Not IsEmpty(Cells(3, iCol))) Then
      If (IsNumeric(Cells(3, iCol))) Then vDt3 = Int(Cells(3, iCol))
    End If
    Select Case t.Row
      Case 1
        Select Case True
          Case IsEmpty(vDt1)
          Case IsEmpty(vDt2) And IsEmpty(vDt3)
          Case IsEmpty(vDt2)
            If (vDt3 > 0) Then Cells(2, iCol) = DateAdd("d", vDt3 - 1, vDt1)
          Case Else
            If (vDt1 > vDt2) Then
              Cells(3, iCol) = Empty
            Else
              Cells(3, iCol) = DateDiff("d", vDt1, vDt2) + 1
            End If
        End Select
      Case 2
        Select Case True
          Case IsEmpty(vDt2)
          Case IsEmpty(vDt1) And IsEmpty(vDt3)
          Case IsEmpty(vDt1)
            If (vDt3 > 0) Then Cells(1, iCol) = DateAdd("d", -(vDt3 - 1), vDt2)
          Case Else
            If (vDt1 > vDt2) Then
              Cells(3, iCol) = Empty
            Else
              Cells(3, iCol) = DateDiff("d", vDt1, vDt2) + 1
            End If
        End Select
      Case 3
        Select Case True
          Case IsEmpty(vDt3)
          Case IsEmpty(vDt1) And IsEmpty(vDt2)
          Case IsEmpty(vDt1)
            If (vDt3 > 0) Then Cells(1, iCol) = DateAdd("d", -(vDt3 - 1), vDt2)
          Case Else
            If (vDt3 <= 0) Then
              Cells(2, iCol) = Empty
            Else
              Cells(2, iCol) = DateAdd("d", vDt3 - 1, vDt1)
            End If
        End Select
    End Select
  Next
  iCol = 0
End Sub

 
Worksheet_Change 内でセルに値を設定すると、また Worksheet_Change が呼ばれるようなので、
処理で設定した後の Worksheet_Change はすぐに戻るように、上記黄色部分で細工。
Worksheet_Change イベント自体を抑止する方法もあるようですが・・・・今回はこれで。

処理的には、どの行が変更されたか・・・・
これを求める前に1~3行の状況を取得しておきます。
変数を Variant にしておいて、Empty かで判別するように・・・・
元々の値が Empty だったら、IsNumeric は True で、Int は 0 を返すので2段で判別するように・・・

へ~~1つ目
日数のところに &H0A を入力してみると IsNumeric は True で、Int は 10 になるんですね。

何か、それなりに動いてくれますね・・・コピー&ペーストされても大丈夫そう・・・・・・・・・

へ~~2つ目
列を挿入すると悲惨な事に・・・・・
列を挿入すると、挿入されたセル全てが Target で得られるようです。
(そのセル分 For Next が Loop しちゃいますね)

処理する行1~3に限定した動きをするようにしましょう・・・ということで
Private Sub Worksheet_Change(ByVal Target As Range)
  Static iCol As Long
  Dim t As Range
  Dim vDt1 As Variant, vDt2 As Variant, vDt3 As Variant

  If (iCol <> 0) Then Exit Sub

  For Each t In Target

この記述部分を以下に変更します。

Private Sub Worksheet_Change(ByVal Target As Range)
  Static iCol As Long
  Dim inTarget As Range, t As Range
  Dim vDt1 As Variant, vDt2 As Variant, vDt3 As Variant

  If (iCol <> 0) Then Exit Sub

  Set inTarget = Intersect(Target, Rows("1:3"))
  If (inTarget Is Nothing) Then Exit Sub


  For Each t In inTarget
と、戻る前で
  Next
  Set inTarget = Nothing
  iCol = 0
End Sub

黄色部分が追加/変更した部分になります。
Intersect を使って1~3行に絞り込みます。

動きとしては、そこそこ良くなったんではなかろうか・・・・
と思っていじっていたら・・・・あれ?・・・あれれ・・・・てなことが

へ~~3つ目
 ABCDE
1開始日2012/04/012012/04/012012/05/01 
2終了日2012/04/30   
3日数302012/05/012012/06/01 
4  2020 
5     

という表示があったとします。
C3:D4 は、貼り付けとかで失敗したのでしょうか。
この C3:D4 部分を C2:D3 へ持っていく時の方法ですが、C3:D4 を選択して枠部分をドラックして
・コピーすると(Ctrlキーを押しながら C2:D3 へ)
 ABCDE
1開始日2012/04/012012/04/012012/05/01 
2終了日2012/04/302012/05/012012/06/01 
3日数303132 
4  2020 
5     

・移動すると(そのまま C2:D3 へ)
 ABCDE
1開始日2012/04/012012/04/012012/05/01 
2終了日2012/04/302012/04/202012/05/20 
3日数302020 
4     
5     

私のイメージとしては、移動してもコピーの結果になって欲しかったな・・・・・
この場合の移動では、Worksheet_Change が2回発生するようです。
移動した直後では、
 ABCDE
1開始日2012/04/012012/04/012012/05/01 
2終了日2012/04/302012/05/012012/06/01 
3日数302020 
4     
5     

となっているようですが、
1回目の時の Target は以下の部分が通知されました。
 ABCDE
1開始日2012/04/012012/04/012012/05/01 
2終了日2012/04/302012/05/012012/06/01 
3日数302020 
4  (Empty)(Empty) 
5     

日数の変更を通知されたので、開始日があることから終了日を求め直し設定します。
2回目の通知は、その変更した内容で以下の部分となりました。
 ABCDE
1開始日2012/04/012012/04/012012/05/01 
2終了日2012/04/302012/04/202012/05/20 
3日数302020 
4     
5     

この動きは通知された Target を元に行っているので、どうしようもないことの様に思えます。
(対策はないのかな・・・・・)

複数のセル(Target)を処理しようとすると無理なのかな・・・・・
コピー&ペーストでの複数処理・・・・・あきらめるのかなぁ・・・・
Target.Count = 1 を判別すべきだろうか・・・・

でも、コピー&ペーストは捨てがたいし・・・・

おかしな動きをする時がある・・・・という事で、そのままで行こうかなっと。
コピー&ペーストは処理するという事にしましたが、例えば C1:D3 に貼り付けると
For Each で得られる Range (Target) の順は
 ABCDE
1開始日2012/04/0112 
2終了日2012/04/3034 
3日数3056 
4     
5     

の様な順になるようです。
ここで、1番目に得られる C1 を処理する時、C2 / C3 の部分も書き変わっているようです。
ということは、列に対して1回処理すればよいことになる???

そこで、処理している列情報を Dictionary で管理することにして以下
Private Sub Worksheet_Change(ByVal Target As Range)
  Static iCol As Long
  Static dic As Object
  Dim inTarget As Range, t As Range
  Dim vDt1 As Variant, vDt2 As Variant, vDt3 As Variant

  If (iCol <> 0) Then Exit Sub

  Set inTarget = Intersect(Target, Rows("1:3"))
  If (inTarget Is Nothing) Then Exit Sub

  If (dic Is Nothing) Then Set dic = CreateObject("Scripting.Dictionary")
  dic.RemoveAll


  For Each t In inTarget
    iCol = t.Column
    If (Not dic.Exists(iCol)) Then
      dic.Item(iCol) = Null

      vDt1 = Empty: vDt2 = Empty: vDt3 = Empty
      If (IsDate(Cells(1, iCol))) Then vDt1 = CDate(Cells(1, iCol))
      If (IsDate(Cells(2, iCol))) Then vDt2 = CDate(Cells(2, iCol))
      If (Not IsEmpty(Cells(3, iCol))) Then
        If (IsNumeric(Cells(3, iCol))) Then vDt3 = Int(Cells(3, iCol))
      End If
      Select Case t.Row
        Case 1
          Select Case True
            Case IsEmpty(vDt1)
            Case IsEmpty(vDt2) And IsEmpty(vDt3)
            Case IsEmpty(vDt2)
              If (vDt3 > 0) Then Cells(2, iCol) = DateAdd("d", vDt3 - 1, vDt1)
            Case Else
              If (vDt1 > vDt2) Then
                Cells(3, iCol) = Empty
              Else
                Cells(3, iCol) = DateDiff("d", vDt1, vDt2) + 1
              End If
          End Select
        Case 2
          Select Case True
            Case IsEmpty(vDt2)
            Case IsEmpty(vDt1) And IsEmpty(vDt3)
            Case IsEmpty(vDt1)
              If (vDt3 > 0) Then Cells(1, iCol) = DateAdd("d", -(vDt3 - 1), vDt2)
            Case Else
              If (vDt1 > vDt2) Then
                Cells(3, iCol) = Empty
              Else
                Cells(3, iCol) = DateDiff("d", vDt1, vDt2) + 1
              End If
          End Select
        Case 3
          Select Case True
            Case IsEmpty(vDt3)
            Case IsEmpty(vDt1) And IsEmpty(vDt2)
            Case IsEmpty(vDt1)
              If (vDt3 > 0) Then Cells(1, iCol) = DateAdd("d", -(vDt3 - 1), vDt2)
            Case Else
              If (vDt3 <= 0) Then
                Cells(2, iCol) = Empty
              Else
                Cells(2, iCol) = DateAdd("d", vDt3 - 1, vDt1)
              End If
          End Select
      End Select
    End If
  Next
  Set inTarget = Nothing
  iCol = 0
End Sub

黄色い部分が処理を追加したところになります。

ただ、この処理にも弊害があって、以下の様なデータを
2012/05/01bbbb
aaaa2012/06/20
2020

C1:D3 に貼り付けると
 ABCDE
1開始日2012/04/012012/05/01bbbb 
2終了日2012/04/302012/05/202012/06/20 
3日数302020 
4     
5     

ということになります。

・貼り付けた先頭行で処理する

こと(が仕様)になります。
これは手間になりますが、考えながら貼り付けることをして頂戴・・・・ってなことで・・・・本当にいいのかな?

これが嫌なら、Dictionary 処理を追加する前のものとすれば、抜けなく書き変わると思います。



今回、サンプルファイルはありません。

こういう方法にすれば良いよ・・・・・教えてください。
関連記事

2012/04/10

Category: やってみる

TB: 0  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △

トラックバック

トラックバックURL
→http://kikutips.blog13.fc2.com/tb.php/125-68d3f86a
この記事にトラックバックする(FC2ブログユーザー)

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。