Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Home Premium : Excel 2003)
配列として無数の数字を取得
投稿日時: 17/08/05 12:45:11
投稿者: inzaghi

 
シートのF33〜下記のような数字が並んでいます。
数字は、無数に並んでいます。
下記の数字を配列として取得し、msgboxで表示させたいのですが、配列として要素が取得できません。
ご教授頂けますでしょうか。
123 245 356 845 365 125 354.11 555.12
 
Sub error_correction_2()
Dim ary() As Double
Dim cnt As Long
Dim myRange As Range
 
Dim i As Long
Dim j As Long
Dim k As Long
Dim higher As Double
Dim center As Double
Dim lower As Double
 
Set myRange = Range("F33:AJ33")
cnt = WorksheetFunction.Count(myRange)
ReDim ary(1 To cnt)
 
i = 0
j = 6
Do While Cells(33, j).Value <> ""
    ary() = Cells(33, i)
i = i + 1
Loop
MsgBox ary(1)
 
End Sub

回答
投稿日時: 17/08/05 13:10:49
投稿者: simple

   Dim r As Range の宣言を追加したうえで、
     

    i = 0
    For Each r In myRange
        i = i + 1
        ary(i) = r.Value
    Next

などとするのでしょうか。
 
二次元の配列でよければ、
  Dim mat as variant
   mat = myRange.Value

で済みますが。
 
後続処理、つまりどんな使い方をするかも説明されたらいいんじゃないでしょうか。

回答
投稿日時: 17/08/05 14:34:57
投稿者: WinArrow
投稿者のウェブサイトに移動

説明に矛盾が見受けられます。
   
  >無数に並んでいます。
といいながら
>Range("F33:AJ33")
と書いている???無数じゃないし
>配列として要素が取得できません
AJ列からF列を差引けば、要素数は求められます。
要素がわからないってことないよね?
   
  >Range("F33:AJ33")
     
のように、範囲が特定できないってことなんではないですか?
   
セルF33が先頭ならば(左側のセルは空白という条件)
 Set myRange = Range("F33").CurrentRegin
で、連続した領域を取得できます。
または
 Set myRange = .Range(.Range("F33"), .Cells(33, .Cells(33, .Columns.Count).End(xlToLeft).Column))
で可変範囲が取得できます。

投稿日時: 17/08/05 19:55:50
投稿者: inzaghi

simple様、WinArrow様ご回答ありがとうございます。
ご指摘がありましたので、後続処理を説明させて頂きます。
 
シートの情報
1.上の行Range("F33:AJ33")は、任意の数値。この中には空欄のセルも含まれています。
2.下の行("G34:AJ34")は、計算式が入っています。計算式は、G34=ABS(F33-G33)。
H34以降は、セルのコピーで同様の計算式。
3.higher(AY11)とlower(AY15)とcenter(AY13)の数値が入っています。
 
シート----------------------------------------
123 245 356 845 365 125 354.11 555.12
- 122 111 489 480 240 229.11 201.01
 
higher300 center 250 lower 200
---------------------------------------------
 
マクロ処理
1.上の行Range("F33:AJ33")の数値とhigher(AY11)とlower(AY15)を一つずつ比較して、
該当すれば、再計算。
2.再計算したセルは再計算した値を入力。
3.下の行("G34:AJ34")も該当のセルだけ再計算。
以上になります。
 
現状、項目2と3がどのように処理すれば達成できるのか理解できません。
確認して頂けますでしょうか。
よろしくお願いいたします。
 
Sub error_correction_2()
Dim ary() As Double
Dim cnt As Long
Dim myRange As Range
Dim r As Range
 
Dim i As Long
Dim j As Long
Dim k As Long
 
Set myRange = Range("F33:AJ33")
cnt = WorksheetFunction.Count(myRange)
ReDim ary(1 To cnt)
 
 
i = 0
j = 6
 
 For Each r In myRange
    If r <> "" Then
         
        i = i + 1
        ary(i) = r.Value
        'MsgBox ary(i)
    Else
    End If
 Next
  
 higher = Cells(11, 51).Value '2σ
 center = Cells(13, 51).Value 'CL
 lower = Cells(15, 51).Value '-2σ
  
 For k = 1 To cnt
        Debug.Print getRandExt(ary(k), 0)
         
 Next
 
 End Sub
Function getRand(x As Double, y As Double) As Double
    getRand = x + (y - x) * Rnd()
         
 End Function
 
 ' 範囲内ならそのまま、範囲外なら補正してランダム値を返す
' opt=0: センターまでの間のランダム値
' opt=1: 上下限値寄りのランダム値
' opt=2: センター寄りのランダム値
Function getRandExt(x As Double, opt As Long) As Double
    If x > higher Then
        Select Case opt
        Case 0: getRandExt = getRand(center, higher)
        'Case 1: getRandExt = getRand((center + higher) / 2, higher)
        'Case 2: getRandExt = getRand(center, (center + higher) / 2)
        End Select
    ElseIf x < lower Then
        Select Case opt
        Case 0: getRandExt = getRand(lower, center)
        'Case 1: getRandExt = getRand(lower, (lower + center) / 2)
        'Case 2: getRandExt = getRand((lower + center) / 2, center)
End Function

投稿日時: 17/08/05 20:01:35
投稿者: inzaghi

コードが上手くコピーできていなかったので、再度載せます。
Sub error_correction_2()
 Dim ary() As Double
 Dim cnt As Long
 Dim myRange As Range
 Dim r As Range
   
 Dim i As Long
 Dim j As Long
 Dim k As Long
   
 Set myRange = Range("F33:AJ33")
 cnt = WorksheetFunction.Count(myRange)
 ReDim ary(1 To cnt)
   
   
 i = 0
 j = 6
   
  For Each r In myRange
     If r <> "" Then
           
         i = i + 1
         ary(i) = r.Value
         'MsgBox ary(i)
     Else
     End If
  Next
    
  higher = Cells(11, 51).Value '2σ
 center = Cells(13, 51).Value 'CL
  lower = Cells(15, 51).Value '-2σ
   
  For k = 1 To cnt
         Debug.Print getRandExt(ary(k), 0)
           
  Next
   
  End Sub
 Function getRand(x As Double, y As Double) As Double
     getRand = x + (y - x) * Rnd()
           
  End Function
   
  ' 範囲内ならそのまま、範囲外なら補正してランダム値を返す
' opt=0: センターまでの間のランダム値
' opt=1: 上下限値寄りのランダム値
' opt=2: センター寄りのランダム値
Function getRandExt(x As Double, opt As Long) As Double
     If x > higher Then
         Select Case opt
         Case 0: getRandExt = getRand(center, higher)
         'Case 1: getRandExt = getRand((center + higher) / 2, higher)
         'Case 2: getRandExt = getRand(center, (center + higher) / 2)
         End Select
     ElseIf x < lower Then
         Select Case opt
         Case 0: getRandExt = getRand(lower, center)
         'Case 1: getRandExt = getRand(lower, (lower + center) / 2)
         'Case 2: getRandExt = getRand((lower + center) / 2, center)
 
     End Select
    Else
        getRandExt = x
    End If
 End Function

回答
投稿日時: 17/08/05 22:47:16
投稿者: simple

そのコードは別の方から提供されたものですか?
 
Debug.Print ということの意味は理解していますか?
イミディエイトウインドウに結果を出力するということです。
コードを提供した方の意図は、
結果の確認のために暫定的にそこに表示させました、
ということだったのでしょう、たぶん。
 
ではどうするか。
 
(1)一番簡単なのは、getRandExtで変換後の値をセルにそのまま書き込むことです。
   どうしても配列にしないといけない、ということもありません。
   まずは簡単な方法から理解すべきです。
 

   higher = Cells(11, 51).Value
    center = Cells(13, 51).Value
    lower = Cells(15, 51).Value 

    For Each r In myRange
        If r.Value <> "" Then
            r.Value = getRandExt(r.Value)
        End If
    Next

(2)速度を向上させる目的で、配列に結果をたくわえて、一括して書き込むこともできます。
 
   higher = Cells(11, 51).Value
    center = Cells(13, 51).Value
    lower = Cells(15, 51).Value 
    
    ' 配列にいったん保持
    i = 0
    For Each r In myRange
        i = i + 1
        ary(i) = r.Value
    Next

    ' 配列に変換処理を加える
    For k = 1 To cnt
        If ary(k) <> "" Then
            ary(k) = getRandExt(ary(k), 0)
        End If
    Next

    '元の配列に書き込む
    myRange.Value = ary

それから変数の宣言についても慎重に。
 
# outlierを意図的に操作して問題ないんですか?

回答
投稿日時: 17/08/05 22:54:46
投稿者: simple

r.Value = getRandExt(r.Value)
とあるのは、
r.Value = getRandExt(r.Value, 0) の間違いです。
 
なお、実際に動かしていないので、エラーになったら、そちらでデバッグしてください。
 
また、元のデータの上に上書きしてしまっているので(これは本当は余り推奨されない)、
元のファイルをバックアップしておくことをお薦めする。

投稿日時: 17/08/06 01:52:35
投稿者: inzaghi

丁寧で理解しやすい説明で感謝致します。
このコードは、今回の目的とは異なりますが、提供して頂いたものを
今回のケースに合わせて手直ししたものです。
Debug.Print は、表面的意味合いで理解しています。
# outlierを意図的に操作して、問題はないです。
backupとしてとってあります。
 
下記のコードで、If ary(k) <> "" Then が型が一致しません。
If ary(k) <> "" Thenを消すと、正常に動作します。
'配列に変換処理を加える
    For k = 1 To cnt
        If ary(k) <> "" Then
            ary(k) = getRandExt(ary(k), 0)
        End If
    Next
どのように直せばよいでしょうか?

回答
投稿日時: 17/08/06 07:42:51
投稿者: simple

最も簡単なのは、あえて配列を使わずに、以下のようにすることです。

    For Each r In myRange
        If r.Value <> "" Then
            r.Value = getRandExt(r.Value, 0)
        End If
    Next

どうしても配列ということなら、こんなことになるでしょう。
 
Dim higher As Double ' Function procedureでも使うので、「モジュールレベル変数」にします。
Dim center As Double ' テキストなどで、考え方をよく理解してください。
Dim lower As Double

Sub error_correction_2()
    Dim ary() As Variant    ' ■ 空白値も扱うならDouble型では不可
    Dim cnt As Long
    Dim myRange As Range
    Dim r As Range

    Dim i As Long
    Dim j As Long
    Dim k As Long

    Set myRange = Range("F33:AJ33")
    'cnt = WorksheetFunction.Count(myRange) ' 空白があるならNG
    cnt = myRange.Count     ' ■ 空白も含めた個数にする必要がある。

    ReDim ary(1 To cnt)

    higher = Cells(11, 51).Value    '2σ
    center = Cells(13, 51).Value    'CL
    lower = Cells(15, 51).Value     '-2σ

    i = 0
    For Each r In myRange
        i = i + 1
        ary(i) = r.Value
    Next

    For k = 1 To cnt
        If ary(k) <> "" Then
            ary(k) = getRandExt(CDbl(ary(k)), 0)    '強制的にDoubleに変換して渡す
        End If
    Next

    myRange.Value = ary

End Sub

Function getRand(x As Double, y As Double) As Double
    getRand = x + (y - x) * Rnd()
End Function

' 範囲内ならそのまま、範囲外なら補正してランダム値を返す
' opt=0: センターまでの間のランダム値
' opt=1: 上下限値寄りのランダム値
' opt=2: センター寄りのランダム値
Function getRandExt(x As Double, opt As Long) As Double
    If x > higher Then
        Select Case opt
        Case 0: getRandExt = getRand(center, higher)
        Case 1: getRandExt = getRand((center + higher) / 2, higher)
        Case 2: getRandExt = getRand(center, (center + higher) / 2)
        End Select
    ElseIf x < lower Then
        Select Case opt
        Case 0: getRandExt = getRand(lower, center)
        Case 1: getRandExt = getRand(lower, (lower + center) / 2)
        Case 2: getRandExt = getRand((lower + center) / 2, center)
        End Select
    Else
        getRandExt = x
    End If
End Function
-------------------------------------
一次元配列にこだわらなければ、普通はこう書きます。
(必要な部分だけ示します。)
 
    Dim mat As Variant
    mat = myRange.Value

    For k = 1 To UBound(mat, 2)
        If mat(1, k) <> "" Then
            mat(1, k) = getRandExt(CDbl(mat(1, k)), 0) '強制的にDouble変換
        End If
    Next

    myRange.Value = mat

参考までにお聞きします。
> 今回の目的とは異なりますが、提供して頂いたものを
> 今回のケースに合わせて手直ししたものです。

目的がどう異なり、どう手直しされたのですか?

投稿日時: 17/08/06 09:03:20
投稿者: inzaghi

長時間にわたり、ご対応ありがとうございます。
動作確認後、処理できていることが確認取れました。
配列にこだわっていた理由として、知識が乏しい為、今回のケースが
良い機会だったので使用してみました。勉強しなおします。
 
>目的がどう異なり、どう手直しされたのですか?
今回のようにhigher,lower値を超えたら再計算して再計算値を転記するが最終的な目的で、
前段階の、再計算のシーケンスをご指導頂きました。具体的な箇所は、差し控えさせていただきます。