返回列表 上一主題 發帖

如何參照資料將勾選項指定至範圍儲存格

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2016-1-5 09:08 | 顯示全部帖子
回復 1# 074063
試試看
  1. Option Explicit
  2. Sub Ex()
  3.     Dim D As Object, i As Integer, Ar(), E As Variant
  4.     Set D = CreateObject("SCRIPTING.DICTIONARY")  '字典物件
  5.     i = 2
  6.     Do While Range("B" & i) <> ""  'B2開始直到B欄沒資料
  7.         If Range("C" & i) <> "" Then
  8.             If Not D.exists(Range("C" & i).Text) Then  '字典物件的key不存在
  9.                 D(Range("C" & i).Text) = Array(Range("b" & i)) '這的key的項目為..
  10.             Else  '字典物件的key已存在
  11.                 Ar = D(Range("C" & i).Text)         'Ar=字典物件的key的項目
  12.                 ReDim Preserve Ar(UBound(Ar) + 1)   '陣列擴充一元素
  13.                 Ar(UBound(Ar)) = Range("b" & i)     '陣列最後元素的值
  14.                 D(Range("C" & i).Text) = Ar         '字典物件的key的項目=Ar
  15.             End If
  16.         End If
  17.         i = i + 1
  18.     Loop
  19.     i = 1
  20.     With Range("E4")
  21.         For Each E In D.ITEMS      '字典物件的項目
  22.             .Cells(1, i).Resize(1, UBound(E) + 1) = E
  23.             i = i + UBound(E) + 3
  24.         Next
  25.     End With
  26. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 2016-1-7 07:43 | 顯示全部帖子
回復 8# 074063
17:20       
~       
19:20       
這時間的邏輯如何設定
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
3#
發表於 2016-1-10 13:54 | 顯示全部帖子
本帖最後由 GBKEE 於 2016-1-12 05:59 編輯

回復 14# 074063
也可以不用 字典物件.
  1. Option Explicit
  2. '*** 類別有變動新增或減少在模組上端修改,不必修改成式碼***
  3. '如果我的類別有3~4組
  4. Const KeyWord = "VOX"
  5. '則區分時間皆在【O】類別前時間為17:20~19:20, 在【X】類別前時間為17:20~18:20....
  6. Const KeyTime = "17:20,~,19:20" & vbLf & "17:20,~,24:20" '& vbLf &......

  8. Dim Rng As Range
  9. Sub Ex_清除資料()
  10.     Set Rng = Sheets("sheet1").Range("h7") '輸入的位置
  11.     With Rng.CurrentRegion
  12.         If Application.CountA(.Cells) > 0 Then .Clear
  13.     End With
  14. End Sub
  15. Sub Ex_資料輸入()
  16.     Dim Ar(0 To Len(KeyWord) - 1), i As Integer, R As Integer, E As Integer, Ar_Time As Variant
  17.     Dim C As Integer
  18.     Ex_清除資料
  19.     Ar_Time = Split(KeyTime, vbLf)  'KeyTime字串分割為陣列
  20.     Application.ScreenUpdating = False
  21.     i = 2
  22.     Do
  23.         R = InStr(KeyWord, Rng.Parent.Cells(i, "C"))  '備註欄的字串,在KeyWord中的順序
  24.         If Rng.Parent.Cells(i, "C") <> "" And R >= 1 Then
  25.             Ar(R - 1) = Ar(R - 1) & Rng.Parent.Cells(i, "B") & vbLf
  26.             '依 KeyWord的字母順序 將姓名欄的資料,導入Ar中
  27.         End If
  28.         i = i + 1
  29.     Loop Until Rng.Parent.Cells(i, "b") = ""  'B欄沒有資料
  30.     '******姓名欄的資料,導入Ar中 完畢****
  31.     i = 0
  32.     For R = 0 To UBound(Ar)
  33.         Ar(R) = Split(Ar(R), vbLf)  '導入Ar中姓名欄資料,分割為陣列
  34.         For C = 0 To UBound(Ar(R)) - 1
  35.             With Rng.Offset(, i).Resize(3)
  36.                 .MergeCells = True
  37.                 .Orientation = xlVertical
  38.                 .Value = Ar(R)(C)
  39.             End With
  40.             i = i + 1
  41.         Next
  42.         If R < UBound(Ar) Then
  43.         For E = 1 To 3
  44.             With Rng.Offset(, i).Resize(, 2).Rows(E)
  45.                 .MergeCells = True
  46.                 .HorizontalAlignment = xlCenter
  47.                 .Value = "'" & Split(Ar_Time(R), ",")(E - 1)
  48.                 '陣列 Ar_Time
  49.             End With
  50.         Next
  51.         End If
  52.         i = i + 2
  53.     Next
  54.     With Rng.CurrentRegion.Font
  55.         .Bold = True
  56.         .ColorIndex = 25
  57.     End With
  58.     Application.ScreenUpdating = True
  59. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 2016-1-12 05:58 | 顯示全部帖子
回復 17# 074063

16# 的程式碼 可修改
  1.    '******姓名欄的資料,導入Ar中 完畢****
  2.     i = 0
  3.     For R = 0 To UBound(Ar)
  4.         If Ar(R) <> "" Then
  5.             Ar(R) = Split(Ar(R), vbLf)  '導入Ar中姓名欄資料,分割為陣列
  6.             For C = 0 To UBound(Ar(R)) - 1
  7.                 With Rng.Offset(, i).Resize(3)
  8.                     .MergeCells = True
  9.                     .Orientation = xlVertical
  10.                     .Value = Ar(R)(C)
  11.                 End With
  12.                 i = i + 1
  13.             Next
  14.         End If
  15.         If R < UBound(Ar) Then
  16.             For E = 1 To 3
  17.                 With Rng.Offset(, i).Resize(, 2).Rows(E)
  18.                     .MergeCells = True
  19.                     .HorizontalAlignment = xlCenter
  20.                     .Value = "'" & Split(Ar_Time(R), ",")(E - 1)
  21.                     '陣列 Ar_Time
  22.                 End With
  23.             Next
  24.         End If
  25.         i = i + 2
  26.     Next
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 有願放在心裡，沒有身體力行，正如耕田不播種，皆是空過因緣。
返回列表 上一主題