Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


8237 / 13644 ツリー ←次へ | 前へ→

【34272】空欄に数字を補完するコードを単純に書き換えたい ちくたく 06/1/30(月) 10:49 質問[未読]
【34275】Re:空欄に数字を補完するコードを単純に書... ちくたく 06/1/30(月) 12:32 発言[未読]
【34281】Re:空欄に数字を補完するコードを単純に... 小僧 06/1/30(月) 16:06 発言[未読]
【34285】Re:空欄に数字を補完するコードを単純に... ちくたく 06/1/30(月) 16:51 質問[未読]
【34287】Re:空欄に数字を補完するコードを単純に... 小僧 06/1/30(月) 18:19 回答[未読]
【34288】Re:空欄に数字を補完するコードを単純に... ちくたく 06/1/30(月) 18:39 お礼[未読]
【34306】Re:空欄に数字を補完するコードを単純に... 小僧 06/1/31(火) 0:23 回答[未読]
【34311】Re:空欄に数字を補完するコードを単純に... ちくたく 06/1/31(火) 9:10 お礼[未読]
【34307】Re:空欄に数字を補完するコードを単純に書... ichinose 06/1/31(火) 7:01 発言[未読]
【34312】Re:空欄に数字を補完するコードを単純に書... ちくたく 06/1/31(火) 9:14 お礼[未読]
【34476】Re:空欄に数字を補完するコードを単純に書... ちくたく 06/2/3(金) 13:12 発言[未読]
【34337】Re:空欄に数字を補完するコードを単純に書... [名前なし] 06/1/31(火) 21:48 発言[未読]
【34478】Re:空欄に数字を補完するコードを単純に書... ちくたく 06/2/3(金) 13:17 お礼[未読]

【34272】空欄に数字を補完するコードを単純に書き...
質問  ちくたく WEB  - 06/1/30(月) 10:49 -

引用なし
パスワード
   いつもお世話になっております。
標題につきまして、質問させて頂きます。
下のように、数値が飛び飛びに入った表があります。
数値が入っていないところは空欄になっています。
この空欄に、数値を補完するという処理を考えています。

で、コードを書いてみたのですが、深みにはまったようで、
えらく複雑になってしまいました。
もっと、単純な書き方はないかなぁ、と思い、質問させて頂きます。

まず、最初の表は、例えば以下のような感じ。

  A  B  C
1 1  3  
2     4
3     
4   7  
5 5    

処理結果は、以下のようになります。
小数点に関しては、丸めてます。

  A  B   C
1 1  3
2 2  4.33 4
3 3  5.66 5.25
4 4  6.99 6.5
5 5  7.99 7.75

コードは以下のようになります。
もっと、単純に書ける気がするのですが、思いつきません。
お知恵をお貸し頂ければ幸いです。

Sub 数値の補完()

  Dim myArr As Variant, cNum As Integer
  Dim myR As Range, i As Integer
  Dim myF As Integer, cMin As Double, cMax As Double
  Dim tmpNum As Double, tmpR(1) As Integer
  Dim j As Integer, sRow As Integer
  
  cNum = 0: myF = 0: cMin = 0: cMax = 0  '//変数の初期化。
  
  For Each myC In Selection.Columns    '//列ごとに処理
    myArr = myC
    cNum = myC.Column: sRow = Selection.Row   '//行と列を取得しておく。
    For i = 1 To UBound(myArr, 1)
      If myArr(i, 1) <> "" Then    '//列のある値が0でなかった場合に、格納。
        If myF = 0 Then
          cMin = myArr(i, 1)
          tmpR(0) = i
          myF = 1
        End If
        If myF = 1 Then       '//で、フラグを使って処理。
          cMax = myArr(i, 1)
          tmpR(1) = i
        End If
        If cMin <> cMax And tmpR(1) - tmpR(0) <> 1 Then   '//実質の処理
          tmpNum = (cMax - cMin) / (tmpR(1) - tmpR(0))
          tmpNum = Round(tmpNum, 2)            '//丸めの処理。今は小数点2位
          For j = tmpR(0) To tmpR(1) - 1
            Cells(sRow + j, cNum).Value = Cells(sRow + j, cNum).Offset(-1, 0).Value + tmpNum
          Next j
          myF = 1: cMin = cMax: cMax = 0: tmpR(0) = tmpR(1)
        End If
      End If
    Next i
  myF = 0: cMin = 0: cMax = 0
  Next myC
End Sub

【34275】Re:空欄に数字を補完するコードを単純に...
発言  ちくたく WEB  - 06/1/30(月) 12:32 -

引用なし
パスワード
   自己レスです。
オブジェクト変数を使って、変数の数は減らしてみました。
でも、やっぱりややこしいです。。。

Sub 数値の補完2()
  
  Dim myC As Range, myR As Range
  Dim tmpN As Double, minR As Range, maxR As Range
  Dim j As Integer, k As Integer
  
  For Each myC In Selection.Columns      'やはり、列ごとに処理
    For Each myR In myC.Cells        'それをセル毎に分解。
      If myR.Value <> 0 Then       'オブジェクトを使って処理する。変数の数は減る。
        If minR Is Nothing Then
          Set minR = myR
        ElseIf Not minR Is Nothing Then
          Set maxR = myR
        End If
        
        If Not minR Is Nothing And Not maxR Is Nothing Then
          tmpN = Round((maxR.Value - minR.Value) / (maxR.Row - minR.Row), 2)
          k = 1
          For j = minR.Row + 1 To maxR.Row - 1
            minR.Offset(k, 0).Value = minR.Value + tmpN * k
            k = k + 1
          Next j
          Set minR = Nothing: Set minR = maxR
        End If
        
      End If
    Next myR
  Next myC
End Sub

【34281】Re:空欄に数字を補完するコードを単純に...
発言  小僧  - 06/1/30(月) 16:06 -

引用なし
パスワード
   ▼ちくたく さん:
こんにちは。

>  A  B  C
>1 1  3  
>2     4
>3     
>4   7  
>5 5    

で何も選択せずに、数値の補完を実行…

For i = 1 To UBound(myArr, 1) の行で型が一致しません、でエラー。

A1 から C5 を選択して実行しましたが、

  A  B   C
1 1  3  
2 2  4.33 4
3 3  5.66  
4 4  6.99  
5 5

で結果が返ってきました。

1) 選択範囲内の処理という事で良いのでしょうか。
2) B5 のような扱いはどうなさいますか。
3) C 列の基準が解りません。
4) C 列にもう一つ数字が入った際、C1に関しては補完しないのでしょうか。

等、色々と解らない事があるのですが…。

【34285】Re:空欄に数字を補完するコードを単純に...
質問  ちくたく E-MAILWEB  - 06/1/30(月) 16:51 -

引用なし
パスワード
   小僧 さん。
返信ありがとうございます。

わかりにくい説明ですいません。
質問を提示頂いたものからお答えします。

>1) 選択範囲内の処理という事で良いのでしょうか。
選択範囲内の処理で考えています。

>2) B5 のような扱いはどうなさいますか。
B5、あるいはC1のように、列の頭や尻で、
その前あるいは後を補完しようはないものは、無視するように考えています。

>3) C 列の基準が解りません。
ごめんなさい、気づきませんでしたが、
Cには5行目移行に数字があります。
その数字に対して、補完しあっています。
なので、私が提示した例では、C列は補完されません。

>4) C 列にもう一つ数字が入った際、C1に関しては補完しないのでしょうか。
2番の質問と同様ですが、列を上から見ていったとき(C1、C2、C3と値をひろっていったとき)、
一番、最初の値が入ったセル(この場合は4)以前は補完しません。

>等、色々と解らない事があるのですが…。
本当に、すいません。。。

なお、最初に書いたコードには、間違いがあって、
For j = minR.Row + 1 To maxR.Row - 1 ←2のはず
 minR.Offset(k, 0).Value = minR.Value + tmpN * k
 k = k + 1
Next j
でした(ちょっと混乱しています。なので、オブジェクト変数を使ったふたつめのコードに書き直してみました。まじめにテストできてないですが。)。
なので、例示した、B4が7から6.99にかわっているのは間違いになります。

流れとしては、
1. 行のデータが一番最初に空白ではなかったときに、
その値(値:A)を覚える。
2. 次にデータがある行まで進み、値(値:B)を覚える。
3. この両者(A、B)をつかって補完する。補完式の概略は、
(B - A) / (BのセルのRow - AのセルのRow) です。
この値を増加量として、A1が1、A5が5の場合に、A2が2、A3が3、、、という感じで、
埋めていくように考えています。
4. で、Aの値に代入しBの値を、再び、データがある行まで、進みあれば、2 に戻ります。

コードの目的を話します。
目的は、知り合いが、この補完をワークシート関数でやろうとしてて、
難しがっていたので、VBAで簡単に出来るのでは、と思い、試してみたところ、
私には、意外に難しかったので、もしかしたら、何かしらの、
わかりやすい方法があるのでは、と(どちらかといえば)興味本位で聞いた次第です。
特に、知り合いにプレゼントしようとは考えていません
(というか、してあげたいのですが、保守性が低くて、責任がとれないのでできません)。

長文になり、申し訳ありません。
よろしくお願い致します。

【34287】Re:空欄に数字を補完するコードを単純に...
回答  小僧  - 06/1/30(月) 18:19 -

引用なし
パスワード
   ▼ちくたく さん:
こんばんは、
稚拙なコードですが、アップしてみます。
Option Explicit

Type tmpType
  Value As Double
  Row As Long
End Type

Sub 配列で処理()
Dim i As Long
Dim j As Long
Dim k As Long
Dim Sabun As Double
Dim varData As Variant
Dim Point As tmpType

'選択範囲を配列で受ける
  varData = Selection.Value

' j は列単位のループ
  For j = LBound(varData, 2) To UBound(varData, 2)
' i は行単位のループ
    For i = LBound(varData, 1) To UBound(varData, 1)
      If varData(i, j) <> "" Then
'ポイントの行が初期化されていなかった場合、差分を取る
        If Point.Row <> 0 Then
          Sabun = (varData(i, j) - Point.Value) / (i - Point.Row)
'空白行に補完
          For k = Point.Row + 1 To i - 1
            varData(k, j) = Point.Value + Sabun * (k - Point.Row)
          Next
        End If
'セルに入っている値と行をポイントにする
        Point.Value = varData(i, j)
        Point.Row = i
      End If
    Next i
'右列にポイント移動…行を初期化
      Point.Row = 0
  Next j

'配列の値をセルに戻す  
  Selection.Value = varData
End Sub

Type ステートメントを使って処理を行ってみました。

【34288】Re:空欄に数字を補完するコードを単純に...
お礼  ちくたく E-MAILWEB  - 06/1/30(月) 18:39 -

引用なし
パスワード
   小僧 さん。
こんばんは。

ありがとうございます。
可読性が私のコードより、断然、高いですね。
(っていうか、私のコードがごちゃごちゃしすぎてるんですが)。。。

それでも、やっぱりちょっと難しめのコードになっちゃいますね。
さっき、私が、処理の流れを示してしまったからかもしれないんですが、
最初に申し上げた処理を行うには、こういった流れが普通になるんですかね。

自分の処理が古くさいのかなぁ、と思うんですが。。。

【34306】Re:空欄に数字を補完するコードを単純に...
回答  小僧  - 06/1/31(火) 0:23 -

引用なし
パスワード
   ▼ちくたく さん:
こんばんは。

>それでも、やっぱりちょっと難しめのコードになっちゃいますね。

掲示板の過去ログを見て、ちくたく さんが綺麗なコードを書かれているので、
当方なりに精一杯恰好つけたつもりです(笑)

選択範囲内をループさせるのではなく、
別の方向から攻めてみました。

Option Explicit

Sub シート処理()
Dim i As Long
Dim j As Long
Dim MyRange As Range
Dim Sabun As Double

  With Selection
  
'列ごとに処理
  For i = 1 To .Columns.Count
  
'基点のセルから Shift + Ctrl + ↓ のセルをつかむ
    Set MyRange = Range(.Cells(i), .Cells(i).End(xlDown))
      
'つかんだセルと選択範囲の最終行を比較
    Do Until MyRange(MyRange.Count).Row > .Cells(.Count).Row

'つかんだセルの最初と最後の差分を個数で割る
      Sabun = (MyRange(MyRange.Count).Value - MyRange(1).Value) / _
          (MyRange.Count - 1)
            
'空白セルに値を代入
      For j = 2 To MyRange.Count - 1
        MyRange(j).Value = MyRange(1).Value + Sabun * (j - 1)
      Next
      
'つかんだセルの最後から Shift + Ctrl + ↓ のセルをつかむ
    Set MyRange = Range(MyRange(MyRange.Count), _
              MyRange(MyRange.Count).End(xlDown))
    Loop
  Next
  End With
  
  Set MyRange = Nothing
End Sub


目安箱にあった Jaka さんのスレッドを参考にさせて頂きました。
http://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=78;id=FAQ

【34307】Re:空欄に数字を補完するコードを単純に...
発言  ichinose  - 06/1/31(火) 7:01 -

引用なし
パスワード
   おはようございます。

ワークシート関数を使ってみました。
新規ブックの未入力のアクティブシートで
適当にセル範囲を選択した状態でsampleを実行してみて下さい。


'========================================================
Sub sample()
  Dim rng As Range
  Set rng = Selection
  With rng
    .Formula = "=if(mod(int(rand()*" & .Count & ")+1,2),"""",int(rand()*" & .Count & ")+1)"
    .Value = .Value
    End With
  MsgBox "sample complete and start test"
  '****************** ↑ サンプル作成
  call test
End Sub
'=================================================================
Sub test()
  Dim idx As Long
  Dim colrng As Range
  Dim crng As Range
  Dim f_ans
  On Error Resume Next
  For Each colrng In Selection.Columns
    If colrng.Rows.Count > 1 Then
     With colrng.SpecialCells(xlCellTypeConstants, xlNumbers)
       idx = 1
       ReDim v(1 To .Count)
       ReDim r(1 To .Count)
       For Each crng In .Cells
        v(idx) = crng.Value
        r(idx) = crng.Row
        idx = idx + 1
        Next
       End With
     For Each crng In colrng.SpecialCells(xlCellTypeBlanks)
       f_ans = Application.Match(crng.Row, r(), 1)
       crng.Value = Round((v(f_ans + 1) - v(f_ans)) / (r(f_ans + 1) - r(f_ans)) * _
                  (crng.Row - r(f_ans)) + v(f_ans), 2)
       Next
     End If
    Next
  Set colrng = Nothing: crng = Nothing
  Erase v(), r()
End Sub

【34311】Re:空欄に数字を補完するコードを単純に...
お礼  ちくたく WEB  - 06/1/31(火) 9:10 -

引用なし
パスワード
   小僧 さん
おはようございます。

>>それでも、やっぱりちょっと難しめのコードになっちゃいますね。
>掲示板の過去ログを見て、ちくたく さんが綺麗なコードを書かれているので、
>当方なりに精一杯恰好つけたつもりです(笑)

いえ、すいません。。。
なんか、そんなに難しい処理には思えないのに、
こんなにややこしくなるんだぁ、、、って思うと。
変なコードだなぁ、と思うのです。
(コードのところどころに意味のわからない記述がありますね、
見直しが足りてません。。。すいません。。。)

>選択範囲内をループさせるのではなく、
>別の方向から攻めてみました。

↓この方法、考えたけど、思いつかなかったんですよ!
>Set MyRange = Range(.Cells(i), .Cells(i).End(xlDown))
>Do Until MyRange(MyRange.Count).Row > .Cells(.Count).Row

提示して頂くと、なるほどなぁ。って感じです。
個人的には、これはすごくわかりやすいコードでした。
ありがとうございます。

>目安箱にあった Jaka さんのスレッドを参考にさせて頂きました。
>http://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=78;id=FAQ

なるほど、気づきませんでした。
重ね重ね、ありがとうございます。

【34312】Re:空欄に数字を補完するコードを単純に...
お礼  ちくたく WEB  - 06/1/31(火) 9:14 -

引用なし
パスワード
   ichinose さん
おはようございます。
返信ありがとうございます。

>ワークシート関数を使ってみました。
>新規ブックの未入力のアクティブシートで
>適当にセル範囲を選択した状態でsampleを実行してみて下さい。

実行してみました。うまくいきました。
しかし(というか、しかしでもないのですが)
私は、ワークシート関数が苦手で、コードの意味を理解するのに、
少し時間がかかりそうです。

ちょっと、本日、私事でばたばたしてしまっているので、
また、詳細については、本日〜明日にかけて確認させて頂き、レスを返させて頂ければと思います。
せっかく、書いて頂いたのに、礼を失い、申し訳ございません。

よろしくお願い致します。

【34337】Re:空欄に数字を補完するコードを単純に...
発言  [名前なし]  - 06/1/31(火) 21:48 -

引用なし
パスワード
   ▼ちくたく さん:
>もっと、単純な書き方はないかなぁ、と思い、質問させて頂きます。
単純かどうかはわかりませんが、こんなのはどうでしょうか?

Sub Macro1()
Dim MyCol As Range
Dim 増加分 As Single
Dim i As Long, j As Long
Dim Large As Double
Dim Small As Double
Dim LargeRow As Long
Dim SmallRow As Long

  '3行以上なければ数値間の空白セルは存在しないので抜ける
  If ActiveWindow.RangeSelection.Rows.Count < 3 Then Exit Sub
  
  '1列ずつ処理
  For Each MyCol In ActiveWindow.RangeSelection.Columns
    With MyCol
    
      '数値が2個以上なければ数値間の空白セルは存在しないので
      '数値が2個以上なら処理する
      If WorksheetFunction.Count(.Cells) > 1 Then
      
        '数値だけを選択
        With .SpecialCells(xlCellTypeConstants, xlNumbers)
        
          '(範囲数 - 1) 回分繰り返す
          '範囲が1つであれば以下のループは処理されない
          For i = 1 To .Areas.Count - 1
          
            '範囲の最終セル(Aとする)の値と行番号を取得
            With .Areas(i)
              With .Cells(.Cells.Count)
                Small = .Value
                SmallRow = .Row
              End With
            End With
            
            '次の範囲の先頭セル(Bとする)の値と行番号を取得
            With .Areas(i + 1).Cells(1)
                Large = .Value
                LargeRow = .Row
            End With
            
            'A,Bのセルから取得した情報を使用して増加分を算出
            増加分 = (Large - Small) / (LargeRow - SmallRow)
            
            'A,Bのセルの間の数だけ、Aのセルの値に増加分を足した値を出力
            For j = SmallRow + 1 To LargeRow - 1
              Cells(j, .Column).Value = Cells(SmallRow, .Column).Value _
              + Format(増加分 * (j - SmallRow), "0.00")
            Next
          Next
        End With
      End If
    End With
  Next

End Sub


数値だけ選択[SpecialCells(xlCellTypeConstants, xlNumbers)]した場合の範囲

   A
1   1  ←Areas(1).Cells(1) 範囲1の先頭セル
2   2  ←Areas(1).Cells(2) [= Areas(1).Cells(Areas(1).Cells.Count)]範囲1の最終セル
3
4
5   3  ←Areas(2).Cells(1) 範囲2の先頭セル
6   4  ←Areas(2).Cells(2)
7   5  ←Areas(2).Cells(3) [= Areas(2).Cells(Areas(2).Cells.Count)]範囲2の最終セル
8
9   6  ←Areas(3).Cells(1) 範囲3の先頭セル

なので、ある範囲の最終セルと次の範囲の先頭セルを使うようなコードに
してみました。

【34476】Re:空欄に数字を補完するコードを単純に...
発言  ちくたく WEB  - 06/2/3(金) 13:12 -

引用なし
パスワード
   ichinose さん
こんにちは。

返信が遅くなり申し訳ございません。
関数リファレンスなんかを首っ丈で、コード読ませて頂きました。
(と、いっても理解が悪いですが)
Match関数を上手にはめ込んでらっしゃるなぁ、と思いました。
正直、この手の条件系のワークシート関数はよくわからないので、
私には絶対に思いつかない手のコードです。

.SpecialCells(xlCellTypeBlanks)

とかも、恥ずかしながら、知りませんでした。
なんか、このコードをちょっと応用させて頂けたら、
また、違う感じのものも書けそうです。

ありがとうございました。

【34478】Re:空欄に数字を補完するコードを単純に...
お礼  ちくたく WEB  - 06/2/3(金) 13:17 -

引用なし
パスワード
   [名前なし] さん
こんにちは。
返信遅くなり申し訳ございません。

>'範囲の最終セル(Aとする)の値と行番号を取得
>'次の範囲の先頭セル(Bとする)の値と行番号を取得

ここの部分の処理がわかりやすいですね。
それと、やっぱり、
SpecialCellsをうまく使ってやるといいのかもしれません。

ありがとうございます。

8237 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free