［Excel］把問卷的結果顯示出來

clonliu wrote:
請教各位先進前輩
我...(恕刪)

Sub Statistics()
    Dim wrk As Worksheet '活頁簿變數
    Dim i As Integer '迴圈變數
    Dim P_Name As String '路人名
    Dim P_Count As Integer '路人數量
    Dim Satisfaction_num As Integer '滿意度分數
    Dim Satisfaction_temp As Integer '暫存滿意度分數，用來比較
    Set wrk = ThisWorkbook.Worksheets(1) '設定wrk為第一個活頁簿
    P_Name = "" '設定初始路人名空白
    P_Count = 0 '設定初始路人數為0
    For i = 2 To wrk.Cells(1048576, 3).End(xlUp).Row '迴圈，第二列至有資料的最尾列
        If Not IsEmpty(wrk.Cells(i, 1).Value) Then '判斷路人名是否不為空
            If P_Name <> CStr(wrk.Cells(i, 1).Value) Then '判斷讀取到的路人名是否與當前迴圈不相同
                P_Count = P_Count + 1 '路人數+1
                P_Name = CStr(wrk.Cells(i, 1).Value) '設定路人數為當前讀取到的路人名
                wrk.Cells(P_Count + 1, 5).Value = P_Name '將路人名寫入統計路人欄位
                Satisfaction_num = 0 '滿意度分數歸零
            End If
        End If
        Dim s As String '宣告字串變數
        s = CStr(wrk.Cells(i, 3).Value) '設定s字串變數為當前回全讀取到的滿意度
        Select Case s '將滿意度改為分數1~5
            Case "非常滿意"
                Satisfaction_temp = 5
            Case "滿意"
                Satisfaction_temp = 4
            Case "尚可"
                Satisfaction_temp = 3
            Case "不滿意"
                Satisfaction_temp = 2
            Case "非常不滿意"
                Satisfaction_temp = 1
            Case Else
                MsgBox "Error" '非以上滿意度顯示Error
        End Select
        If Satisfaction_num = 0 Then '判斷滿意度分數是否為初始值
            Satisfaction_num = Satisfaction_temp '滿意度分數是初始值則將該路人第一個讀取到的滿意度分數存入滿意度分數
        Else
            If Satisfaction_temp < Satisfaction_num Then '滿意度分數不是初始值則比較該路人目前讀取到的滿意度分數與該路人第一個讀取到的滿意度分數
                Satisfaction_num = Satisfaction_temp '該路人目前讀取到的滿意度分數低於該路人第一個讀取到的滿意度分數，則將目前滿意度分數寫入滿意度分數
            End If
        End If
        If P_Count <> 0 Then '判斷是否不為初始路人數
            Select Case Satisfaction_num '判定最終保留的最低滿意度分數是幾分，再轉為文字並寫入滿意度
                Case 5
                    wrk.Cells(P_Count + 1, 6).Value = "非常滿意"
                Case 4
                    wrk.Cells(P_Count + 1, 6).Value = "滿意"
                Case 3
                    wrk.Cells(P_Count + 1, 6).Value = "尚可"
                Case 2
                    wrk.Cells(P_Count + 1, 6).Value = "不滿意"
                Case 1
                    wrk.Cells(P_Count + 1, 6).Value = "非常不滿意"
                Case Else
                    MsgBox "Error" '非以上滿意度顯示Error
            End Select
        End If
    Next
    MsgBox "Done!" '執行完成
End Sub

clonliu wrote:
請教2樓大大我嘗試著...(恕刪)

小小尉 wrote:
提供VBA方式 把問...(恕刪)

Sub test()
    
    Dim Satisfaction As Object, dic As Object, r As Integer, i As Integer, n As Integer
    Set Satisfaction = CreateObject("System.Collections.ArrayList")
    Set dic = CreateObject("Scripting.Dictionary")
    
    dic.Add "非常滿意", 5:    dic.Add "滿意", 4:    dic.Add "尚可", 3:    dic.Add "不滿意", 2:    dic.Add "非常不滿意", 1
    dic.Add 5, "非常滿意":   dic.Add 4, "滿意":   dic.Add 3, "尚可":   dic.Add 2, "不滿意":   dic.Add 1, "非常不滿意"
    n = 2: r = 2:    Range("e2:f" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
    
    Do
        
        Cells(n, 5) = Cells(r, 1)
        If Cells(r, 1).MergeCells = True Then
            For i = r To r + Cells(r, 1).MergeArea.Rows.Count - 1
                Satisfaction.Add dic(Cells(i, 3).Value)
            Next i
            Satisfaction.Sort
            r = r + Cells(r, 1).MergeArea.Rows.Count
        Else
            Satisfaction.Add dic(Cells(r, 3).Value)
            r = r + 1
        End If
        Cells(n, 6) = dic(Satisfaction(0))
        n = n + 1
        Satisfaction.Clear
        
    Loop Until Cells(r, 1) = "" And Cells(r, 1).MergeCells = False
    
    Set Satisfaction = Nothing
    Set dic = Nothing
    
End Sub