[attach]31761[/attach]

1.欄位置入公式
Sub ex()
Dim r As Integer
r = Range("A65535").End(3).Row    '計數資料數
[H2].Resize(r - 1) = "=countif(\$B\$2:\$D\$" & r & ",A2)"   '正向次數加總欄放入公式
[I2].Resize(r - 1) = "=countif(\$E\$2:\$G\$" & r & ",A2)"   '負向次數加總欄放入公式
[J2].Resize(r - 1) = "=Standardize(H2, \$P\$2, \$Q\$2)"     'LM欄放入公式
[K2].Resize(r - 1) = "=Standardize(I2, \$P\$2, \$Q\$2)"     'LL欄放入公式
[L2].Resize(r - 1) = "=Sum(J2:K2)"                      'SI欄放入公式
[M2].Resize(r - 1) = "=J2 - K2"                         'SP欄放入公式
[N2].Resize(r - 1) = "=IF(AND((J2>0)*(K2<0)*(M2>1)=1),""受歡迎"",IF(AND((J2<0)*(K2>0)*(M2<-1)=1),""被拒絕"",IF(AND((J2<0)*(K2<0)*(L2<-1)=1),""被忽視"",IF(AND((J2>0)*(K2>0)*(L2>1)=1),""受爭議"",IF(AND((M2<1)*(M2>-1)*(L2<1)*(L2>-1)=1),""平均組"")))))"   '分類欄放入公式
End Sub

2.直接計算相關數值
Sub ex1()
Dim r, x As Integer
For r = 2 To Range("A65535").End(3).Row
x = 0
'------計算正向次數加總
For Each Rng In Range([B2], [D65535].End(3))
If Cells(r, "a") = Rng Then x = x + 1
Next
Cells(r, "H") = x
x = 0
'------計算負向次數加總
For Each Rng In Range([E2], [G65535].End(3))
If Cells(r, "a") = Rng Then x = x + 1
Next
Cells(r, "I") = x
Next
For r = 2 To Range("A65535").End(3).Row
Cells(r, "J") = WorksheetFunction.Standardize(Cells(r, "H"), Range("P2"), Range("Q2"))
Cells(r, "K") = WorksheetFunction.Standardize(Cells(r, "I"), Range("P2"), Range("Q2"))
Cells(r, "L") = Cells(r, "J") + Cells(r, "K")
Cells(r, "M") = Cells(r, "J") - Cells(r, "K")
If Cells(r, "J") > 0 And Cells(r, "K") < 0 And Cells(r, "M") > 1 Then Cells(r, "N") = "受歡迎"
If Cells(r, "J") > 0 And Cells(r, "K") > 0 And Cells(r, "L") > 1 Then Cells(r, "N") = "受爭議"
If Cells(r, "J") < 0 And Cells(r, "K") > 0 And Cells(r, "M") < -1 Then Cells(r, "N") = "被拒絕"
If Cells(r, "J") < 0 And Cells(r, "K") < 0 And Cells(r, "L") < -1 Then Cells(r, "N") = "被忽視"
If Cells(r, "M") < 1 And Cells(r, "M") > -1 And Cells(r, "L") < 1 And Cells(r, "L") > -1 Then Cells(r, "N") = "平均組"
Next
End Sub

 歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)