[發問] 依合計資料自動敘獎

h60327

優缺點相抵後，優點達12次者嘉獎2次；優點達6次者嘉獎1次，請問如何根據Q欄資料，於「本案獎懲建議名冊」依獎懲事由內容自動敘獎並依高低排序，彙整後如「本案獎懲建議名冊」

GBKEE

回復 1# h60327

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Ar(), xi As Integer, xB As Integer, Rng As Range
   
4.     xi = 4
   
5.     xB = 0
   
6.     With Sheets("一組")
   
7.         Do While .Cells(xi, "B") <> ""            '執行迴圈Do Loop的條件: B欄的儲存格 <> ""
   
8.             If .Cells(xi, "Q") >= 6 Then          'Q欄的儲存格>=6
   
9.                 ReDim Preserve Ar(1 To 6, xB)     '動態陣列: ReDim(調整)  最後一維元素的數量(xB)
   
10.                 'Preserve 選擇性引數。當改變原有陣列最後一維的大小時，仍然保有原來的資料的關鍵字。
    
11.                 Set Rng = Sheets("人資").Cells.Find(.Cells(xi, "B")) 'Sheets("人資")中尋找 .Cells(xi, "B") :
    
12.                 Ar(1, xB) = Rng.Cells(1, 2)       '寫入:姓名欄往右2欄
    
13.                 Ar(2, xB) = Rng.Cells(1, 3)
    
14.                 Ar(3, xB) = Rng                   '寫入:姓名欄
    
15.                 Ar(4, xB) = Rng.Cells(1, 4)
    
16.                 Ar(5, xB) = "100下半年優點達" & IIf(.Cells(xi, "Q") >= 12, "12", "6") & "次，辛勞得力"
    
17.                 Ar(6, xB) = "嘉獎" & IIf(.Cells(xi, "Q") >= 12, "貳次（4002）", "壹次（4001）")
    
18.                 xB = xB + 1                       '最後一維元素的數量(xB)
    
19.             End If
    
20.             xi = xi + 1                           '使B欄的儲存格往下一列移動
    
21.         Loop
    
22.     End With
    
23.     If xB <> 0 Then Sheets("本案獎懲建議名冊").[a3].Resize(xB, 6) = Application.Transpose(Ar)
    
24.     ' Transpose : 轉置(工作表函數)
    
25. End Sub

複製代碼

h60327

完全適用,非常感謝版主的協助,可惜自己的程度還是太差,對於程式碼的內容還是不知其所以然

h60327

GBKEE版主您真是太貼心了,非常感謝您的說明

h60327

再請教GBKEE版主,如果是多工作表時又要如何變化呢?再次感謝不吝指教了.

GBKEE

回復 5# h60327

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Ar(), xi As Integer, xB As Integer, Rng As Range, xSh As Variant
   
4.     xB = 0                                            '動態陣列:  最後一維元素的數量(xB)
   
5.     For Each xSh In Array("一組", "二組", "三組")     '陣列: 須處裡的工作表名稱
   
6.         With Sheets(xSh)                              '代入陣列元素
   
7.             xi = 4                                    '設定工作表開始的儲存格的列數
   
8.             Do While .Cells(xi, "B") <> ""            '執行迴圈Do Loop的條件: B欄的儲存格 <> ""
   
9.                 If .Cells(xi, "Q") >= 6 Then          'Q欄的儲存格>=6
   
10.                     ReDim Preserve Ar(1 To 6, xB)     '動態陣列: ReDim(調整)  最後一維元素的數量(xB)
    
11.                     'Preserve 選擇性引數。當改變原有陣列最後一維的大小時，仍然保有原來的資料的關鍵字。
    
12.                     Set Rng = Sheets("人資").Cells.Find(.Cells(xi, "B")) 'Sheets("人資")中尋找 .Cells(xi, "B") :
    
13.                     Ar(1, xB) = Rng.Cells(1, 2)       '寫入:姓名欄往右2欄
    
14.                     Ar(2, xB) = Rng.Cells(1, 3)
    
15.                     Ar(3, xB) = Rng                   '寫入:姓名欄
    
16.                     Ar(4, xB) = Rng.Cells(1, 4)
    
17.                     Ar(5, xB) = "100下半年優點達" & IIf(.Cells(xi, "Q") >= 12, "12", "6") & "次，辛勞得力"
    
18.                     Ar(6, xB) = "嘉獎" & IIf(.Cells(xi, "Q") >= 12, "貳次（4002）", "壹次（4001）")
    
19.                     xB = xB + 1                       '最後一維元素的數量(xB)
    
20.                 End If
    
21.                 xi = xi + 1                           '使B欄的儲存格往下一列移動
    
22.             Loop
    
23.         End With
    
24.     Next
    
25.     If xB <> 0 Then                                   '動態陣列有元素存在
    
26.         With Sheets("本案獎懲建議名冊")
    
27.             .Range(.[a3], .[a3].End(xlDown)).Resize(, 6) = ""          '清除原有內容
    
28.             .[a3].Resize(xB, 6) = Application.Transpose(Ar)            ' Transpose : 轉置(工作表函數)
    
29.         End With
    
30.         MsgBox "符合的資料 共 " & xB & "筆"
    
31.     Else
    
32.         MsgBox "查無 符合的資料"
    
33.     End If
    
34. End Sub

複製代碼

h60327

感謝版主的協助，並預祝各位版主們新春愉快，佳節快樂‧