ハピタス登録で1,000円分になるURL
アンケートの集計VBA
入力完了をポチすると集計タブに転記する。こう。
入力完了をポチると
集計タブに結果が反映される。
グラフシートでは複数回答をグラフにした。
VBAソース
Sub 入力完了_Click()
' With ThisWorkbook.Sheets("集計")
' 'アンケート結果をコピー
' ThisWorkbook.Sheets("入力").Range("C2").CurrentRegion.Copy ThisWorkbook.Sheets("集計").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
' End With
Dim wsInput As Worksheet
Dim wsOutput As Worksheet
Dim lastRow As Long
Dim inputRange As Range
Dim OutputRange As Range
Dim OutputRange2 As Range
Dim i As Long
' シートを参照
Set wsInput = Worksheets("入力")
Set wsOutput = Worksheets("集計")
' B列からAH列までの範囲を取得
Set OutputRange2 = wsOutput.Range("B:AH")
' 最終行を取得
lastRow = OutputRange2.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
' 集計シートの最終行を取得
'lastRow = wsOutput.Cells(wsOutput.Rows.Count, "B").End(xlUp).Row + 1
'Sheet「入力」のC2からC34までの範囲を取得
Set inputRange = wsInput.Range("C2:C34")
' Sheet「集計」の最新の空白行から始まる範囲を取得
Set OutputRange = wsOutput.Cells(lastRow, "B").Resize(inputRange.Rows.Count, 1)
'C2からC34までのセルを最新の空白行にコピー＝行列を入れ替えて貼り付け
For i = 1 To inputRange.Rows.Count
'OutputRange.Cells(i, 1).Value = inputRange.Cells(i, 1).Value
OutputRange.Cells(1, i).Value = inputRange.Cells(i, 1).Value
Next i
MsgBox ("集計シートに反映しました")
'入力値をクリア
Range("C2:C34").Value = Empty
Range("C2").Select
'' Sheet「入力」のC2セルの値を Sheet「集計」の最新の空白行（B列）にコピー
'wsOutput.Cells(lastRow, "B").Value = wsInput.Range("C2").Value
'
'' Sheet「入力」のC3セルの値を Sheet「集計」の最新の空白行（C列）にコピー
'wsOutput.Cells(lastRow, "C").Value = wsInput.Range("C3").Value
'
'' Sheet「入力」のC4セルの値を Sheet「集計」の最新の空白行（D列）にコピー
'wsOutput.Cells(lastRow, "D").Value = wsInput.Range("C4").Value
End Sub
Sub クリア_Click()
'MsgBox ("hello")
'Range("D3").Value = Empty
Range("C2:C34").Value = Empty
Range("C3").Select
End Sub
