Excel VBA質問箱 IV

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

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


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

【44128】チェックレポートの作成について 夜勤労働者 06/11/5(日) 9:56 質問[未読]
【44130】Re:チェックレポートの作成について ichinose 06/11/5(日) 10:09 発言[未読]
【44134】Re:チェックレポートの作成について 夜勤労働者 06/11/5(日) 13:02 質問[未読]
【44136】Re:チェックレポートの作成について Hirofumi 06/11/5(日) 18:03 回答[未読]
【44137】Re:チェックレポートの作成について ichinose 06/11/5(日) 20:29 発言[未読]
【44150】Re:チェックレポートの作成について 夜勤労働者 06/11/6(月) 14:06 質問[未読]
【44161】Re:チェックレポートの作成について ichinose 06/11/6(月) 21:31 発言[未読]

【44128】チェックレポートの作成について
質問  夜勤労働者  - 06/11/5(日) 9:56 -

引用なし
パスワード
   お早うございます。
 取り込まれたデータをチェックするめ、以下の計算式を使って、一応正常に動いて
います。 
 毎回チェック時に計算式の作成とシートの上から底まで結果チェック作業を省けたい
と思いますが、いい方法はあるのでしょうか?ご指導ください。

IF(MOD(C2,$B2)<>0,"×","○")

A  B    C    D    E    C結果   D結果  E結果
あ  2    4    6   50     ○    ○    ○
い  3    4    6    258    ×    ○    ○
う  4    12   16    3     ○    ○    ×

【44130】Re:チェックレポートの作成について
発言  ichinose  - 06/11/5(日) 10:09 -

引用なし
パスワード
   ▼夜勤労働者 さん:
おはようございます。

> 取り込まれたデータをチェックするめ、以下の計算式を使って、一応正常に動いて
>います。 
> 毎回チェック時に計算式の作成とシートの上から底まで結果チェック作業を省けたい
>と思いますが、いい方法はあるのでしょうか?ご指導ください。

VBAで一括で数式を設定する方法です。
>
>IF(MOD(C2,$B2)<>0,"×","○")
>
>A  B    C    D    E    C結果   D結果  E結果
>あ  2    4    6   50     ○    ○    ○
>い  3    4    6    258    ×    ○    ○
>う  4    12   16    3     ○    ○    ×

C結果、D結果、E結果という見出しがそれぞれセルF1、G1、H1だとすると

標準モジュールに

'===========================================================
Sub test()
  Dim rng As Range
  Set rng = Range("a2", Cells(Rows.Count, "a").End(xlUp))
  If rng.Row > 1 Then
    With rng.Offset(0, 5).Resize(, 3)
      .Formula = "=if(mod(rc[-3],rc2)<>0,""×"",""○"")"
      End With
    End If
End Sub

として、当該シートをアクティブにした状態で
上記のtestを実行してみてください。

F列〜H列のデータが存在する行(A列のデータで存在チェックをしています)に
数式が設定されます。

【44134】Re:チェックレポートの作成について
質問  夜勤労働者  - 06/11/5(日) 13:02 -

引用なし
パスワード
   ichinoseさん
返事ありがとうございます。
>C結果、D結果、E結果という見出しがそれぞれセルF1、G1、H1だとすると
[test]を動かしました。F2:H784(行数は可変のため)に正しい結果が表示されました。
本当に助かりました。

 チェック結果(F2:H784)をシートに置かせず、メッセージボックスに"×"の座標を
羅列することは、可能でしょうか?

【44136】Re:チェックレポートの作成について
回答  Hirofumi  - 06/11/5(日) 18:03 -

引用なし
パスワード
   こんなかな?
ただ、"×"の数が多いとMsgBoxで表示しきれるか疑問ですが?

Option Explicit

Public Sub Sample()

  'データ列数(A列〜E列の5列)
  Const clngColumns As Long = 5
  '除数の有る列位置(基準セルからの列Offsetで指定)
  Const clngDivisor = 1
  
  Dim i As Long
  Dim j As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim vntDivisor As Variant
  Dim vntDividend As Variant
  Dim strResult As String
  Dim strProm As String
  
  'Listの左上隅セル位置を基準として設定(列見出しの最左セル位置)
  Set rngList = ActiveSheet.Cells(1, "A")
  With rngList
    'データ行数を取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    'データが無い場合
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '除数データを配列に取得
    vntDivisor = .Offset(1, clngDivisor).Resize(lngRows + 1).Value
    '被除数データを配列に取得
    vntDividend = .Offset(1, clngDivisor + 1) _
            .Resize(lngRows + 1, _
              clngColumns - clngDivisor - 1).Value
  End With
  
  'データ行全てに就いて繰り返し
  For i = 1 To lngRows
    '除数が0じゃ無い場合
    If vntDivisor(i, 1) <> 0 Then
      '被除数に就いて繰り返し
      For j = 1 To clngColumns - clngDivisor - 1
        'もし、剰余が有るなら
        If vntDividend(i, j) Mod vntDivisor(i, 1) > 0 Then
          '変数にセル位置を追加
          If strResult <> "" Then
            strResult = strResult & " "
          End If
          strResult = strResult & rngList.Offset(i, _
                clngDivisor + j).Address(False, False)
        End If
      Next j
    End If
  Next i
  
  If strResult = "" Then
    strProm = "×の該当無し"
  Else
    strProm = "×の該当 " & strResult
  End If
  
Wayout:
  
  Set rngList = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

【44137】Re:チェックレポートの作成について
発言  ichinose  - 06/11/5(日) 20:29 -

引用なし
パスワード
   ▼夜勤労働者 さん:
こんばんは。


> チェック結果(F2:H784)をシートに置かせず、メッセージボックスに"×"の座標を
>羅列することは、可能でしょうか?
できますけど、せっかく便利なセルを有効利用しなければ
宝の持ち腐れだと思いますけどね!!


'=================================================================
Sub test2()
  Dim idx As Long, jdx As Long
  Dim rng As Range
  Dim add1 As String
  Dim add2 As String
  Dim ans As Variant
  Dim mes As String
  Set rng = Range("a2", Cells(Rows.Count, "a").End(xlUp))
  If rng.Row > 1 Then
    With rng
      add1 = .Offset(0, 2).Resize(, 3).Address
      add2 = .Offset(0, 1).Address
      ans = Evaluate("=transpose(if(mod(" & add1 & "," & add2 & _
              ")<>0,ADDRESS(ROW(" & add1 & "),COLUMN(" & add1 & ")),""""))")
      End With
    For idx = LBound(ans, 2) To UBound(ans, 2)
      For jdx = LBound(ans, 1) To UBound(ans, 1)
        If ans(jdx, idx) <> "" Then
         mes = mes & ans(jdx, idx) & vbCrLf
         End If
        Next
      Next
    If mes <> "" Then MsgBox mes
    End If
End Sub


敢えてするならこのようなコードでしょうか?
但し、Msgboxは表示文字数に制限があったと思いますから、
あまり表示するセル範囲が多いと全て表示されないことを制限事項とします。

【44150】Re:チェックレポートの作成について
質問  夜勤労働者  - 06/11/6(月) 14:06 -

引用なし
パスワード
   レイアウトの変更があって、修正はうまくいかず、止まってしまいました。
教えていただけませんか?
実施したいこと:
チェック範囲及び基準値を以下のように変更する場合は、
チェック範囲:C2:E760(3列)===>G5:K760(5列)へ変更
基準値:B2===>L5

修正結果:
Sub test02()
Dim idx As Long, jdx As Long
  Dim rng As Range
  Dim add1 As String
  Dim add2 As String
  Dim ans As Variant
  Dim mes As String
  Set rng = Range("a5", Cells(Rows.Count, "a").End(xlUp)) →2から5へ
  If rng.Row > 1 Then
    With rng
      add1 = .Offset(0, 7).Resize(, 5).Address  →2から7へ、2から5へ
      add2 = .Offset(0, 1).Address
      ans = Evaluate("=transpose(if(mod(" & add1 & "," & add2 & _
              ")<>0,ADDRESS(ROW(" & add1 & "),COLUMN(" & add1 & ")),""""))")
      End With
      For idx = LBound(ans, 2) To UBound(ans, 2)
       For jdx = LBound(ans, 1) To UBound(ans, 1)
         If ans(jdx, idx) <> "" Then
           mes = mes & ans(jdx, idx) & vbCrLf
         End If
       Next
      Next
      If mes <> "" Then
       MsgBox mes, , "データのチェック"  →タイトルを付けました
      End If
   End If
End Sub

チェック範囲及び基準値を以下のように変更する場合は、
チェック範囲:C2:E760(3列)===>G5:K760(5列)へ変更
基準値:B2===>L5

【44161】Re:チェックレポートの作成について
発言  ichinose  - 06/11/6(月) 21:31 -

引用なし
パスワード
   ▼夜勤労働者 さん:
こんばんは。


>レイアウトの変更があって、修正はうまくいかず、止まってしまいました。
>教えていただけませんか?
これは、元のコードをじっくり時間をかけて解釈されて
ご自分で手直しされたほうが良いと思いますけどね!!

>実施したいこと:
>チェック範囲及び基準値を以下のように変更する場合は、
>チェック範囲:C2:E760(3列)===>G5:K760(5列)へ変更
>基準値:B2===>L5
>
>修正結果:
>Sub test02()
>Dim idx As Long, jdx As Long
>  Dim rng As Range
>  Dim add1 As String
>  Dim add2 As String
>  Dim ans As Variant
>  Dim mes As String
>  Set rng = Range("a5", Cells(Rows.Count, "a").End(xlUp)) →2から5へ
'   ↑このコードがA列に入力されているデータを元に
'    入力されているデータ範囲を取得しようとしていることが理解できないと
'    応用が利きませんよ!!

  If rng.Row > 4 Then
   '↑データの始まりが5行以上であることが処理を行うための最初のハードル
>    With rng
      add1 = .Offset(0, 6).Resize(, 5).Address
'      ↑G列〜K列なら上記のように修正、よく意味を考えてください
      add2 = .Offset(0, 11).Address
'      ↑L列が除数の列なら上記になります。
>      ans = Evaluate("=transpose(if(mod(" & add1 & "," & add2 & _
>              ")<>0,ADDRESS(ROW(" & add1 & "),COLUMN(" & add1 & ")),""""))")
>      End With
>      For idx = LBound(ans, 2) To UBound(ans, 2)
>       For jdx = LBound(ans, 1) To UBound(ans, 1)
>         If ans(jdx, idx) <> "" Then
>           mes = mes & ans(jdx, idx) & vbCrLf
>         End If
>       Next
>      Next
>      If mes <> "" Then
>       MsgBox mes, , "データのチェック"  →タイトルを付けました
>      End If
>   End If
>End Sub
>
>チェック範囲及び基準値を以下のように変更する場合は、
>チェック範囲:C2:E760(3列)===>G5:K760(5列)へ変更
>基準値:B2===>L5

きちんと意味を理解されながら、修正してみてください

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