Excel VBA質問箱 IV

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

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


4732 / 76732 ←次へ | 前へ→

【77616】マクロ化の検討
質問  VBAビギナー  - 15/11/10(火) 15:58 -

引用なし
パスワード
   以前こちらで、ご質問させていただき迅速な回答に感激しました。
ありがとうございました。

さて、さっそくですが今回下記の用な表をVBAもしくはEXCEL関数等を使って
1〜2回の動作で作りたいのですが、何か良い案はありますでしょうか。


製品            製品重量    糖度
みかんA            10g        10
みかんA            11g        10
みかんA            12g        10
みかんB            15g        18
みかんB            17g        20
みかんB            16g        20
りんごA            20g        5
りんごA            22g        5
りんごA            21g        5
りんごA            25g        5
りんごB            27g        8
ぶどう            30g        25
ぶどう            33g        25
ぶどう            31g        24



みかんA            12g        ok
みかんB            17g        error
りんごA            25g        ok
りんごB            27g        ok
ぶどう            33g        error


商品の重量は最大値を、糖度は同じでなければエラーとなるようにしたい。
商品それぞれの検索範囲(データベース)が必要になると思うのでそれぞれの検索範囲が決定するような方法をみつけなければならないように思います。

今考えているのが、かなり回りくどいのですが、
1.品名が違う場合は、その手前で○をつける。
2.○のついたセルをコピーしSheet2に貼り付ける。←ここまで完成。
3.Sheet2に貼り付けた製品名を一つずつ検索し、Sheet3に貼り付ける。
(みかんAとみかんBとのセルの間隔を十分あけ、かぶらないよう貼り付ける。)
4.Sheet3に貼り付けられたそれぞれのデータベースから最大値等を検出、コピーしSheet5に貼り付ける。

下記に今回作ったVBAを記載します。この他の方法でも何か良い案がございましたら、
是非参考にさせていただきたく存じます。回答お待ちしております。
よろしくお願いします。
-----------------------------------------------------------------------
Sub ボタン2_Click()
  Dim myrow As Integer
  Dim i As Integer

  myrow = Cells(Rows.Count, 2).End(xlUp).Row
  
    For i = 1 To myrow
  
      If Not Cells(i, 2).Value = Cells(i + 1, 2).Value Then
      Cells(i, 1).Value = "○"
    
  
    End If
    
  Next i
  
End Sub

-----------------------------------------------------------------------
Sub ボタン3_Click()

Dim foundcell As Range, firstcell As Range
  Set foundcell = Cells.Find(what:="○")
  If foundcell Is Nothing Then
    MsgBox "見つかりません"
    Exit Sub
  Else
    Set firstcell = foundcell
    foundcell.Resize(1, 2).Copy Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
  End If
  Do
    Set foundcell = Cells.FindNext(foundcell)
    If foundcell.Address = firstcell.Address Then
      Exit Do
    Else
      foundcell.Resize(1, 2).Copy Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    End If
  Loop
End Sub

1 hits

【77616】マクロ化の検討 VBAビギナー 15/11/10(火) 15:58 質問[未読]
【77617】Re:マクロ化の検討 独覚 15/11/10(火) 17:32 回答[未読]
【77618】Re:マクロ化の検討 独覚 15/11/10(火) 17:34 発言[未読]
【77621】Re:マクロ化の検討 VBAビギナー 15/11/11(水) 8:36 お礼[未読]
【77619】Re:マクロ化の検討 β 15/11/10(火) 19:49 発言[未読]
【77622】Re:マクロ化の検討 VBAビギナー 15/11/11(水) 8:40 回答[未読]

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