Excel VBA質問箱 IV

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

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


75224 / 76732 ←次へ | 前へ→

【5950】Re:分割→コピー
回答  ichinose  - 03/6/10(火) 23:39 -

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

>【sheet1】
> A    B    C    D     E
>−−−−−−−−−−−−−−−−−−−−−−
>1.09    1.26    300    L    70
>1.63    2.19    1000    L    95
>2.56    2.91    600    L    95
>3.09    3.40    400    L    80
>3.84    4.20    800    R    95
>4.42    4.75    1000    L    95
>5.05    5.10    600    L    95
>5.31    5.33    370    L    75
このSheet1のA列、B列値が整列されているという条件下で
(例えば、最終行にデータ追加で 10.00 15.00は、Okだけど、
 4.76 5.00は駄目) 

>
>【sheet2】
> A    B
>0    
>0.01
>0.02
>・
>・
>・
>1.08
>1.09   70
>1.10   70
>1.11   70
>・
>・
>
>※わからないことがありますのでご教授願います。
> sheet2はA列に0より0.01刻みで94.2まであるとします。
> sheet1は1つの行に対して、A列の数値からB列の数値まではE列の数値であることを示しています。
> そこで、たとえばsheet1において(A列)1.09から(B列)1.26までは(E列)70であるので、sheet2の(A列)1.09から1.26までは(B列)70を入力するマクロを考えたいのです。
>範囲外のところは空欄にします。

'================================================================
Sub main()
  Dim s1rng()
  Dim s2rng()
  Dim ans As Range
  Application.ScreenUpdating = False
  With Worksheets("sheet1")
   ReDim s1rng(1 To .Cells(.Rows.Count, 1).End(xlUp).Row, 1 To 5)
   s1rng() = .Range("a1", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 5).Value
   End With
  With Worksheets("sheet2")
   ReDim s2rng(1 To .Cells(.Rows.Count, 1).End(xlUp).Row, 1 To 2)
   s2rng = .Range("a1", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 2).Value
   Set ans = .Range("a1", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 2)
   s2id = 1
   s1id = 1
   Do While s1id <= UBound(s1rng(), 1) And s2id <= UBound(s2rng(), 1)
    f_flg = 0
    Do While s2id <= UBound(s2rng(), 1)
     If s2rng(s2id, 1) >= s1rng(s1id, 1) And s2rng(s2id, 1) <= s1rng(s1id, 2) Then
       s2rng(s2id, 2) = s1rng(s1id, 5)
       f_flg = 1
     Else
       If f_flg = 1 Then Exit Do
       s2rng(s2id, 2) = ""
       End If
     s2id = s2id + 1
     Loop
    s1id = s1id + 1
    Loop
   End With
   ans.Value = s2rng()
  Application.ScreenUpdating = True
End Sub
2 hits

【5946】分割→コピー jun 03/6/10(火) 16:36 質問
【5950】Re:分割→コピー ichinose 03/6/10(火) 23:39 回答
【5951】Re:分割→コピー ichinose 03/6/11(水) 6:36 発言
【5952】Re:分割→コピー jun 03/6/11(水) 8:59 お礼

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