VBAでマクロを作りたいのですが、、、困ってます

質問

1問目に答えた人で2問目に答えた人は何人いたか・・・
2問目で初めて答えた人は何人いたか・・・・というのを計算させたいです。

たとえば(1)のデータがあった時に、(2)のデータのように変換したいとしたらどのようなVBAマクロにすればよいのでしょうか。

(1)
質問No,回答者,
1,AAAAA
1,BBBBB
1,CCCCC
1,AAAAA
2,AAAAA
2,BBBBB
3,AAAAA
3,DDDDD

(2)
1 2 3 ←回答回数

1問目 3 2 1
2問目 0 0
3問目 1

上の結果ですが、
1問目で1回目に答えたのはAAAAA,BBBBB,CCCCCの3人、
1問目に答えて2問目に答えたのは、AAAAA,BBBBBの2人、
そのまま2問目に答えた人で3問目にも答えたのはAAAAAの1人、

2問目で初めて答えた人、その中で2問答えたのは0人

3問目で初めて答えた人は、DDDDDの１人

のような表を意味しています。

データは２万行ほどあるので、VBAで処理しなければならないと考えています。
ほかにも何か方法があれば教えていただけると助かります。
どうぞよろしくお願いします。

回答No.4

tom04

No.3です。

質問より少しだけデータを増やして試してみると
思い通りの結果になりませんでした。
前回のコードはすべて消去して↓のコードに変更してみてください。

Sub Sample2()
Dim i As Long, j As Long, lastRow As Long, cnt As Long
Dim c As Range, wS2 As Worksheet, wS3 As Worksheet
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
wS2.Cells.Clear
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A")
Range(.Cells(1, "B"), .Cells(lastRow, "B")).SpecialCells(xlCellTypeVisible).Copy
wS3.Range("B1").PasteSpecial Paste:=xlPasteValues
wS3.Range("B:B").AdvancedFilter Action:=xlFilterCopy, copytorange:= _
wS3.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1), unique:=True
wS3.Range("B:B").ClearContents
Next i
wS3.Range("A:B").Delete
.AutoFilterMode = False
wS2.Range("A1") = "回答回数"
For i = 1 To wS3.Cells(1, Columns.Count).End(xlToLeft).Column
wS2.Cells(Rows.Count, "A").End(xlUp).Offset(1) = i & "問目"
wS2.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = i
Next i
'▼1問目の処理
wS2.Range("B2") = wS3.Cells(Rows.Count, "A").End(xlUp).Row - 1
For j = 2 To wS3.Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To wS3.Cells(Rows.Count, j).End(xlUp).Row
If WorksheetFunction.CountIf(Range(wS3.Columns(1), wS3.Columns(j - 1)), wS3.Cells(i, j)) > 0 Then
cnt = cnt + 1
End If
Next i
wS2.Cells(2, j + 1) = cnt
cnt = 0
Next j
'▼2問目以降の処理
For j = 2 To wS3.Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To wS3.Cells(Rows.Count, j).End(xlUp).Row '←訂正★
If WorksheetFunction.CountIf(Range(wS3.Columns(1), wS3.Columns(j)), wS3.Cells(i, j)) = 1 Then
cnt = cnt + 1
End If
'▽ここから訂正★
Set c = wS2.Rows(1).Find(cnt, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
wS2.Cells(j + 1, c.Column) = cnt
End If
cnt = 0
Next i
Next j
wS3.Cells.Clear
wS2.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
'△ここまで★
End With
Application.ScreenUpdating = True
wS2.Activate
MsgBox "処理完了"
End Sub

※　サンプル数が少ないので、お望み通りになっているかどうか判りませんが、
まだまだ手直しが必要かもしれませんが、
とりあえず試してみてください。m(_ _)m

回答No.3

tom04

こんばんは！

お望み通りになっているかどうか判りませんが・・・
一例です。
元データはSheet1のA・B列にあり、Sheet2に表示するようにしています。

標準モジュールに↓のコードをコピー＆ペーストしてマクロを実行してみてください。
尚、Sheet3を作業用のSheetとして使用していますので、
Sheet3は全く使用していない状態にしておいてください。

Sub Sample1()
Dim i As Long, j As Long, lastRow As Long, cnt As Long
Dim wS2 As Worksheet, wS3 As Worksheet
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
wS2.Cells.Clear
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True
For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A")
Range(.Cells(1, "B"), .Cells(lastRow, "B")).SpecialCells(xlCellTypeVisible).Copy
wS3.Range("B1").PasteSpecial Paste:=xlPasteValues
wS3.Range("B:B").AdvancedFilter Action:=xlFilterCopy, copytorange:= _
wS3.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1), unique:=True
wS3.Range("B:B").ClearContents
Next i
wS3.Range("A:B").Delete
.AutoFilterMode = False
wS2.Range("A1") = "回答回数"
For i = 1 To wS3.Cells(1, Columns.Count).End(xlToLeft).Column
wS2.Cells(Rows.Count, "A").End(xlUp).Offset(1) = i & "問目"
wS2.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = i
Next i
'▼1問目の処理
wS2.Range("B2") = wS3.Cells(Rows.Count, "A").End(xlUp).Row - 1
For j = 2 To wS3.Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To wS3.Cells(Rows.Count, j).End(xlUp).Row
If WorksheetFunction.CountIf(Range(wS3.Columns(1), wS3.Columns(j - 1)), wS3.Cells(i, j)) > 0 Then
cnt = cnt + 1
End If
Next i
wS2.Cells(2, j + 1) = cnt
cnt = 0
Next j
'▼2問目以降の処理
For j = 2 To wS3.Cells(1, Columns.Count).End(xlToLeft).Column
For i = j To wS3.Cells(Rows.Count, j).End(xlUp).Row
If WorksheetFunction.CountIf(Range(wS3.Columns(1), wS3.Columns(j)), wS3.Cells(i, j)) = 1 Then
cnt = cnt + 1
End If
wS2.Cells(Rows.Count, i + 1).End(xlUp).Offset(1) = cnt
cnt = 0
Next i
Next j
wS3.Cells.Clear
With wS2.Range("A1").CurrentRegion
.SpecialCells(xlCellTypeBlanks).Delete shift:=xlToLeft
.Borders.LineStyle = xlContinuous
End With
End With
Application.ScreenUpdating = True
wS2.Activate
MsgBox "処理完了"
End Sub

※　当方の解釈が間違っているかもしれませんので、
確認したい場合はコードの最後の方にある

＞ wS3.Cells.Clear
＞With wS2.Range("A1").CurrentRegion
＞.SpecialCells(xlCellTypeBlanks).Delete shift:=xlToLeft
＞.Borders.LineStyle = xlContinuous
＞End With

の5行を消去してマクロを実行してみてください。
Sheet3にはA列から1問目の回答者を重複なしに行方向に表示しています。
B列は2問目・C列は3問目・・・
となるはずです。

Sheet2の2行目以降は○問目に初めて回答した数を表示していますので、
空白セルがあるのはその質問には回答していないというコトになります。

とりあえずはこの程度で・・・m(_ _)m

回答No.2

High_Score

行数は何万でも同じです。VBAなど不要です。やり方を整理出来るかどうかです。後はずいっと引っ張るだけです。

求めたい数値をA～Fとして質問内容を整理すると、以下のようになります。
１問目A B C
２問目D E
３問目F

A=（１のみ回答の人数）＋（１と２回答の人数）＋（全問回答の人数）
B=１と２のみ回答＋全問回答
C=全問回答
D=回答が２のみ＋２と３のみ
E=回答が２と３のみ
F=回答が３のみ

以下のようにしました。
AAAAAさんが回答した質問Noの合計を見れば、どの質問に答えたか判別出来ます。

合計１→１のみ回答
合計２→２のみ回答
合計３→１と２を回答または３のみ回答
合計４→１と３のみ回答
合計５→２と３のみ回答
合計６→全問回答

A=（合計が１の人数）＋（合計が３かつ回答数が２個の人数）＋（合計が６の人数）
B=合計が３の人数＋合計が６の人数
C=合計が６の人数
D=合計が２の人数＋５の人数
E=合計が５の人数
F=合計が３かつ回答数が１個の人数

手順１：名前リストの作成
(1)名前の列のみ別シートにコピーし「重複を削除する」機能を使用（使えるバージョンですか？）
(2)重複削除済のリストを元のシートの右の方、例えばD列に戻す。

手順２：各人の質問Noの合計を求める
(1)E列トップ（つまりE1）に関数 =sumif(B:B,D1,A:A) と記入
(2)(1)のセルを選択しセル右下角にカーソルを当てて十字印が出たらそれを掴み最終列まで引っ張る。各人の質問Noの合計が出る

手順３：各人の回答数を求める
(1)F列トップに関数 =countif(B:B,D1) と記入し、下まで引っ張る

手順４：A～Fを求める
A：空いてるセルを選び =countif(E:E,1)+countifs(E:E,3,F:F,2)+countif(E:E,6)
B：=countifs(E:E,3,F:F,2)+countif(E:E,6)
C：=countif(E:E,6)
D：=countif(E:E,2)+countif(E:E,5)
E：=countif(E:E,5)
F：=countifs(E:E,3,F:F,1)

回答No.1

bunjii

>データは２万行ほどあるので、VBAで処理しなければならないと考えています。
>ほかにも何か方法があれば教えていただけると助かります。
VBAによる処理の方が良いと思います。
私はVBAが不得手なので作業用テーブルを使った関数の応用で例を提示します。
回答者の数が多すぎると無理かと思いますが、模擬データの範囲で数式を具体的に提示します。
貼付画像のA列とB列が元データとしました。
前処理の作業用テーブル1と2を作成します。
I2=(COUNTIFS($A$2:$A$9,$D2,$B$2:$B$9,I$1)>0)*1
右と下に必要数コピーします。
N2=IF(AND(SUM(I$2:I2)=1,SUM(N$1:N1)=0),1,"")
同様に右と下に必要数コピーします。
集計結果は作業用テーブル1と2から必要範囲を対象に集計しました。
E2=SUM(N2:Q2)
F2=COUNTIFS($I2:$L2,1,$I3:$L3,1)
G2=COUNTIFS($I2:$L2,1,$I3:$L3,1,$I4:$L4,1)
其々を下へ必要数コピーしました。
集計方法に誤りがありましたら補足してください。