ExcelVBA 数値の個数を順に抽出するには

質問

添付画像の「Ａ1：Ｈ４」のような表があります。

まず検査値１の「Ｂ2：Ｈ2」をマクロを使って調べて、
下の「Ｊ８：Ｑ８」のように出力できたらと考えています。

検査値２と検査値３も同じ感じです。

For～Next や Do ～ Loop　などで試してみたのですが、
エラーが出てうまくいきません。

良い方法がありますでしょうか？

回答No.1

keithin · ベストアンサー

簡単のためＢ：Ｈ列（計７個）は固定とします

Sub macro1()
　Dim a
　Dim r As Long
　Dim c As Long

　For r = 2 To Range("A65536").End(xlUp).Row
　　a = Application.Frequency(Cells(r, "B").Resize(1, 7), Cells(r, "B").Resize(1, 7))
　　For c = 1 To 7
　　　If a(c, 1) <> 0 Then
　　　　Cells(r, "IV").End(xlToLeft).Offset(0, 1) = Cells(r, c + 1) & "が" & a(c, 1) & "個"
　　　End If
　　Next c
　Next r
End Sub

お礼

ありがとうございました。うまく動きました。アレンジして使わせていただきます。

回答No.5

kagakusuki

ANo.4のワークシート関数を利用した、ナンチャッテVBAです。（出力結果はワークシート関数ではなく、単なる文字列データに変換しています。又、元データーの個数が多い場合には、For～Nextよりも高速で処理する事が可能です）

Sub macro()

With ActiveSheet.Range("J8:Q10")
.FormulaR1C1 = _
"=IF(OR(COUNT(R[-6]C2:R[-6]C8)=0,IF(COLUMNS(C10:C)=1,FALSE,IF(INDIRECT(""RC[-1]"",FALSE)="""",TRUE,COUNTIF(INDIRECT(""RC[-1]"",FALSE),MAX(R[-6]C2:R[-6]C8)&""が*個"")))),"""",SMALL(R[-6]C2:R[-6]C8,IF(COLUMNS(C10:C)=1,1,COUNTIF(R[-6]C2:R[-6]C8,""<=""&LEFT(INDIRECT(""RC[-1]"",FALSE),FIND(""が"",INDIRECT(""RC[-1]"",FALSE)&""が"")-1))+1))&""が""&COUNTIF(R[-6]C2:R[-6]C8,SMALL(R" & _
"[-6]C8,IF(COLUMNS(C10:C)=1,1,COUNTIF(R[-6]C2:R[-6]C8,""<=""&LEFT(INDIRECT(""RC[-1]"",FALSE),FIND(""が"",INDIRECT(""RC[-1]"",FALSE)&""が"")-1))+1)))&""個"")"
.Value = .Value
End With

End Sub

お礼

ありがとうございました。計算式でできるなんて初めてしりました。
今回は検査値が３６５もありExcelが重くなってしまうので、次回に活かしたいと思います、

回答No.4

kagakusuki

回答:No.3です。
　先程の回答の関数でも問題なく動作致しますが、「万が一、I列のセルを削除する様な事があった場合においても、エラーを出さない様にする」という観点から考えますと、以下の様な関数の方が、より望ましいかも知れません。

=IF(OR(COUNT($B2:$H2)=0,IF(COLUMNS($J:J)=1,FALSE,IF(INDIRECT("RC[-1]",FALSE)="",TRUE,COUNTIF(INDIRECT("RC[-1]",FALSE),MAX($B2:$H2)&"が*個")))),"",SMALL($B2:$H2,IF(COLUMNS($J:J)=1,1,COUNTIF($B2:$H2,"<="&LEFT(INDIRECT("RC[-1]",FALSE),FIND("が",INDIRECT("RC[-1]",FALSE)&"が")-1))+1))&"が"&COUNTIF($B2:$H2,SMALL($B2:$H2,IF(COLUMNS($J:J)=1,1,COUNTIF($B2:$H2,"<="&LEFT(INDIRECT("RC[-1]",FALSE),FIND("が",INDIRECT("RC[-1]",FALSE)&"が")-1))+1)))&"個")

回答No.3

kagakusuki

VBAを使わずとも、関数でも出来ます。

　まず、J8セルに次の関数を入力して下さい。

=IF(OR(COUNT($B2:$H2)=0,AND(COLUMNS($J:J)>1,I2="")),"",IF(COUNTIF(I2,MAX($B2:$H2)&"が*個"),"",SMALL($B2:$H2,IF(COLUMNS($J:J)=1,1,COUNTIF($B2:$H2,"<="&LEFT(I2,FIND("が",I2&"が")-1))+1))&"が"&COUNTIF($B2:$H2,SMALL($B2:$H2,IF(COLUMNS($J:J)=1,1,COUNTIF($B2:$H2,"<="&LEFT(I2,FIND("が",I2&"が")-1))+1)))&"個"))

　そして、J8セルをコピーして、J8:Q10の範囲に貼り付けて下さい。

　以上です。

回答No.2

tom04

こんばんは！
一例です。

Sheet1のデータをSheet2に表示するようにしてみました。
Alt+F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt+F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, j As Long, k As Long, n As Long, cnt As Long
Dim wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")

wS2.Cells.ClearContents
For i = 2 To wS1.Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To wS1.Cells(1, Columns.Count).End(xlToLeft).Column
If WorksheetFunction.CountIf(wS2.Rows(i), wS1.Cells(i, j)) = 0 Then
wS2.Cells(i, Columns.Count).End(xlToLeft).Offset(, 1) = wS1.Cells(i, j)
End If
Next j
n = wS2.Cells(i, Columns.Count).End(xlToLeft).Column
Range(wS2.Cells(i, 2), wS2.Cells(i, n)).Sort _
Key1:=wS2.Cells(i, 2), Order1:=xlAscending, Header:=xlYes, Orientation:=xlLeftToRight
For k = 2 To wS2.Cells(i, Columns.Count).End(xlToLeft).Column
cnt = WorksheetFunction.CountIf(wS1.Rows(i), wS2.Cells(i, k))
wS2.Cells(i, k) = wS2.Cells(i, k) & "が" & cnt & "個"
Next k
Next i
wS1.Columns(1).Copy wS2.Cells(1, 1)
wS2.Columns.AutoFit
End Sub 'この行まで

こんな感じではどうでしょうか？m(_ _)m

お礼

ありがとうございました。うまく動きました。アレンジして使わせていただきます。