Excel VBA質問箱 IV

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

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


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

【29593】値の振り分けです。よろしくお願いします... ℃素人 05/10/8(土) 18:56 質問[未読]
【29594】Re:値の振り分けです。よろしくお願いしま... Hirofumi 05/10/8(土) 20:53 回答[未読]
【29595】Re:値の振り分けです。よろしくお願いしま... Hirofumi 05/10/8(土) 21:10 発言[未読]
【29618】Re:値の振り分けです。よろしくお願いし... ℃素人 05/10/9(日) 16:27 お礼[未読]
【29596】Re:値の振り分けです。よろしくお願いしま... ichinose 05/10/8(土) 22:43 発言[未読]
【29619】Re:値の振り分けです。よろしくお願いし... ℃素人 05/10/9(日) 16:41 お礼[未読]
【29624】Re:値の振り分けです。よろしくお願いし... ichinose 05/10/9(日) 18:06 発言[未読]
【29667】Re:値の振り分けです。よろしくお願いし... ℃素人 05/10/11(火) 12:20 お礼[未読]

【29593】値の振り分けです。よろしくお願いします...
質問  ℃素人  - 05/10/8(土) 18:56 -

引用なし
パスワード
   いつも参考にさせていただいております。
以前,質問させていただきました,℃素人と申します。
自身で試行錯誤ためしてみたのですが,うまくいきませんでした。
大変申し訳ないのですが,
前回に加えご教示お願いします。
以前の質問+αなのですが,以下に詳細を載せさせていただきます。

------------------------------------------------
項目2において,n試行(下の例の場合は1試行と2試行)前と比較し,
同じであれば same列 へ異なれば different列 へ
項目1の値を振り分けたいのです
(例えば,1試行前と比較の場合,10試行目がAで9試行目がBであれば→different列へ試行10の項目1の400を)。

試行 項目1  項目2 same different 
10   400    A      400
9   500    B      500
8   450    A   450        項目2において,
7   550    A   550        1試行前と比較する場合
6   500    A      500
5   600    B      600     
4   400    A      400
3   300    B      300
2   350    A   350
1   400    A   /   /

試行 項目1  項目2 same different 
10   400    A   400
9   500    B      500    
8   450    A   450         項目2において,
7   550    A      550      2試行前と比較する場合
6   500    A   500    
5   600    B   600     
4   400    A   400     
3   300    B      300    
2   350    A   /   /
1   400    A   /   /
------------------------------------------------
という内容を以前に質問させていただき,
ichinose様に
------------------------------------------------
Sub main()
  Dim comptry As Variant
  Dim rng As Range
  comptry = Application.InputBox("比較する試行前入力", , , , , , , 1)
  'ここで、1とか2とかを指定します。

  If TypeName(comptry) <> "Boolean" Then
    Set rng = Range("a2", Cells(Rows.Count, 1).End(xlUp))
    If rng.Row > 1 Then
     With rng.Offset(0, 3).Resize(, 2)
       .Formula = Array( _
         "=if(a2<=" & comptry & ",""***"",IF(C2=C" & 2 + comptry & ",B2,""""))", _
         "=if(a2<=" & comptry & ",""***"",IF(C2=C" & 2 + comptry & ","""",b2))")
       End With
     End If
    End If
End Sub
------------------------------------------------
をいただいたのですが,

今回は,項目2においてn試行前と比較し
n試行前がA,Bでなくスペース(以下では,分かりやすいように" "としてあります)であれば,
same,different列には何も記載しない(スペース)と追加したいのです。
また,項目2がスペースの試行(下の上例ですと,8試行と4試行)もsame,different列には何も記載しないようにしたいです。

試行 項目1  項目2 same different 
10   400    A      400
9   500    B      " "
8   450   " "   " "        項目2において,
7   550    A   550        1試行前と比較する場合
6   500    A      500
5   600    B      " "     
4   400   " "      " "
3   300    B      300
2   350    A   350
1   400    A   /   /

試行 項目1  項目2 same different 
10   400    A      " "
9   500    B      500    
8   450   " "  " "         項目2において,
7   550    A      550      2試行前と比較する場合
6   500    A   500    
5   600    B   600     
4   400    A   400     
3   300    B      " "     
2   350    A   /   /
1   400   " "   /   /

という具合にしたいのです。
質問ばかりで失礼ですが,
どなたかご教示いただけますでしょうか。
申し訳ありませんが,よろしくお願いします。

【29594】Re:値の振り分けです。よろしくお願いし...
回答  Hirofumi  - 05/10/8(土) 20:53 -

引用なし
パスワード
   上手く行かなかったらゴメン
疑問に思うのは、
>same,different列には何も記載しない(スペース)と追加したいのです。
スペースを入れる事と、何もし無い事とは違うんですけど?

Option Explicit

Public Sub Sample()

  Dim i As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim vntData As Variant
  Dim vntResult As Variant
  Dim vntStep As Variant
  Dim strProm As String
  
  vntStep = Application.InputBox("比較する試行前入力", , , , , , , 1)
  If VarType(vntStep) = vbBoolean Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If
  
  'Listの左上隅を基準とする(列見出しがある物とします)
  Set rngList = ActiveSheet.Cells(1, "A")
  With rngList
    'データ行数を取得
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
    If lngRows <= 1 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '項目1、項目2を配列に取得
    vntData = .Offset(1, 1).Resize(lngRows, 2).Value
  End With
  '結果用配列を確保
  ReDim vntResult(1 To lngRows, 1 To 2)
  
  For i = 1 To lngRows - vntStep
    '項目2がスペースの試行で無ければ
    If Trim(vntData(i, 2)) <> "" Then
      'n試行前がA,Bでなくスペースで無ければ
      If Trim(vntData(i + vntStep, 2)) <> "" Then
        '項目2において,n試行前と比較し,同じであれば
        If vntData(i, 2) = vntData(i + vntStep, 2) Then
          vntResult(i, 1) = vntData(i, 1)
        Else
          vntResult(i, 2) = vntData(i, 1)
        End If
'      Else
'        'スペースを入れる
'        vntResult(i, 2) = " "
      End If
'    Else
'      'スペースを入れる
'      vntResult(i, 1) = " "
    End If
  Next i
  
  Application.ScreenUpdating = False
  
  '結果を出力
  rngList.Offset(1, 3).Resize(lngRows, 2).Value = vntResult
  
  Application.ScreenUpdating = True
  
  strProm = "処理が完了しました"
  
Wayout:

  Set rngList = Nothing
  
  Beep
  MsgBox strProm

End Sub

【29595】Re:値の振り分けです。よろしくお願いし...
発言  Hirofumi  - 05/10/8(土) 21:10 -

引用なし
パスワード
   尚、下に"/"を入れるなら
以下を追加して下さい

'      'スペースを入れる
'      vntResult(i, 1) = " "
    End If
  Next i
  
  For i = lngRows - vntStep + 1 To lngRows '★追加
    vntResult(i, 1) = "/" '★追加
    vntResult(i, 2) = "/" '★追加
  Next i '★追加

  Application.ScreenUpdating = False
  
  '結果を出力

【29596】Re:値の振り分けです。よろしくお願いし...
発言  ichinose  - 05/10/8(土) 22:43 -

引用なし
パスワード
   ℃素人 さん、Hirofumiさん、こんばんは。

前回の投稿を記述していただいたので、
思い出すのが容易でした。

私の個人的な感想としては、℃素人 さんのご質問は
非常にわかりやすい記述だと思います。

前回のコードほんのちょっと変更しました。


'====================================================
Sub main()
  Dim comptry As Variant
  Dim rng As Range
  comptry = Application.InputBox("比較する試行前入力", , , , , , , 1)
  'ここで、1とか2とかを指定します。

  If TypeName(comptry) <> "Boolean" Then
    Set rng = Range("a2", Cells(Rows.Count, 1).End(xlUp))
    If rng.Row > 1 Then
     With rng.Offset(0, 3).Resize(, 2)
       .Formula = Array( _
         "=if(a2<=" & comptry & ",""/"",if(or(c2="""",c" & 2 + comptry & "=""""),"""",IF(C2=C" & 2 + comptry & ",B2,"""")))", _
         "=if(a2<=" & comptry & ",""/"",if(or(c2="""",c" & 2 + comptry & "=""""),"""",IF(C2=C" & 2 + comptry & ","""",b2)))")
       End With
     End If
    End If
End Sub


確認してみて下さい。

【29618】Re:値の振り分けです。よろしくお願いし...
お礼  ℃素人  - 05/10/9(日) 16:27 -

引用なし
パスワード
   Hirofumi様

返信遅れてすいません。
早々の回答,ありがとうございます。
思っていた通りに完璧に動きました。
本当にありがとうございました。

【29619】Re:値の振り分けです。よろしくお願いし...
お礼  ℃素人  - 05/10/9(日) 16:41 -

引用なし
パスワード
   ichinose様

返信遅れてすいません。
以前と重ね,お礼申し上げます。
ichinose様から頂いたものを貼り付けてみたのですが,
後に述べた
「項目2がスペースの試行もsame,different列には何も記載しないようにしたい」
はできたのですが,
先に述べた
「項目2においてn試行前と比較しn試行前がA,Bでなくスペースであれば,
same,different列にはスペースと追加したい」
ができませんでした。

とはいえ,非常に参考になりました。本当にありがとうございました。
ichinose様の書き込みはいつも参考にさせていただいております。
これからも勉強させていただきます。
ありがとうございました。

【29624】Re:値の振り分けです。よろしくお願いし...
発言  ichinose  - 05/10/9(日) 18:06 -

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

>返信遅れてすいません。
>以前と重ね,お礼申し上げます。
>ichinose様から頂いたものを貼り付けてみたのですが,
>後に述べた
>「項目2がスペースの試行もsame,different列には何も記載しないようにしたい」
>はできたのですが,
>先に述べた
>「項目2においてn試行前と比較しn試行前がA,Bでなくスペースであれば,
>same,different列にはスペースと追加したい」
>ができませんでした。
ん?℃素人 さんが提示されたサンプルデータで試して見ましたが、
結果も提示されたとおりでしが・・・。
では、大事を取って、Trim関数も追加して見ました。
'===========================================================
Sub main()
  Dim comptry As Variant
  Dim rng As Range
  comptry = Application.InputBox("比較する試行前入力", , , , , , , 1)
  'ここで、1とか2とかを指定します。

  If TypeName(comptry) <> "Boolean" Then
    Set rng = Range("a2", Cells(Rows.Count, 1).End(xlUp))
    If rng.Row > 1 Then
     With rng.Offset(0, 3).Resize(, 2)
       .Formula = Array( _
         "=if(a2<=" & comptry & ",""/"",if(or(trim(c2)="""",trim(c" & 2 + comptry & ")=""""),"""",IF(C2=C" & 2 + comptry & ",B2,"""")))", _
         "=if(a2<=" & comptry & ",""/"",if(or(trim(c2)="""",trim(c" & 2 + comptry & ")=""""),"""",IF(C2=C" & 2 + comptry & ","""",b2)))")
       End With
     End If
    End If
End Sub


これでどうでしょうか?

【29667】Re:値の振り分けです。よろしくお願いし...
お礼  ℃素人  - 05/10/11(火) 12:20 -

引用なし
パスワード
   ichinose様

返信遅れて申し訳ありません。
何度もすいません。
今度はうまくいきました。
親切丁寧に教えていただき,本当にありがとうございました!

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