Board logo

標題: [發問] 依合計資料自動敘獎 [打印本頁]
作者: h60327    時間: 2012-1-17 14:28     標題: 依合計資料自動敘獎

本帖最後由 GBKEE 於 2012-1-17 15:32 編輯

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

本帖最後由 GBKEE 於 2012-1-18 08:20 編輯

回復 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    時間: 2012-1-17 21:26

完全適用,非常感謝版主的協助,可惜自己的程度還是太差,對於程式碼的內容還是不知其所以然
作者: h60327    時間: 2012-1-18 08:54

GBKEE版主您真是太貼心了,非常感謝您的說明
作者: h60327    時間: 2012-1-18 10:12

再請教GBKEE版主,如果是多工作表時又要如何變化呢?再次感謝不吝指教了.
作者: GBKEE    時間: 2012-1-18 10:46

回復 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    時間: 2012-1-18 15:43

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



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