Excel VBA質問箱 IV

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

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


13327 / 13646 ツリー ←次へ | 前へ→

【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 お礼

【5946】分割→コピー
質問  jun  - 03/6/10(火) 16:36 -

引用なし
パスワード
   【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

【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を入力するマクロを考えたいのです。
範囲外のところは空欄にします。

【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

【5951】Re:分割→コピー
発言  ichinose  - 03/6/11(水) 6:36 -

引用なし
パスワード
   ▼jun さん:
おはようございます。
Match関数使うと、ちょっとだけスッキリしたので
別解です。

'==========================================================
Sub main3()
  Dim s1rng As Range
  Dim s2rng As Range
  Dim s1crng As Range
  Application.ScreenUpdating = False
  With Worksheets("sheet1")
   Set s1rng = .Range("a1", .Cells(.Rows.Count, 1).End(xlUp))
   End With
  With Worksheets("sheet2")
   Set s2rng = .Range("a1", .Cells(.Rows.Count, 1).End(xlUp))
   For Each s1crng In s1rng
    With s2rng.Offset(0, 1)
     Worksheets("sheet2").Range(.Cells(Mymatch(s1crng, s2rng)), .Cells(Mymatch(s1crng.Offset(0, 1), s2rng))).Value = s1crng.Offset(0, 4).Value
     End With
    Next
   End With
  Application.ScreenUpdating = True
End Sub
'=========================================================
Function Mymatch(rng1 As Range, rng2 As Range) As Long
  On Error Resume Next
  Mymatch = WorksheetFunction.Match(rng1, rng2, 1)
  On Error GoTo 0
End Function

【5952】Re:分割→コピー
お礼  jun  - 03/6/11(水) 8:59 -

引用なし
パスワード
   ▼ichinose さん:
おはようございます。
早速、Match関数による別解を試してみました。
・・・エレガントに解決しました。
ありがとうございました。

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