| |
以前こちらで、ご質問させていただき迅速な回答に感激しました。
ありがとうございました。
さて、さっそくですが今回下記の用な表をVBAもしくはEXCEL関数等を使って
１〜２回の動作で作りたいのですが、何か良い案はありますでしょうか。
製品 製品重量 糖度
みかん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
|
|
VBAビギナー
- 15/11/10(火) 15:58 -
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
≪
