12
返回列表 上一主題 發帖

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

GBKEE

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

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

TOP

074063

帖子
129 
主題
47 
精華
0 
積分
206 
點名
0  
作業系統
7 
軟體版本
2007 
閱讀權限
20 
性別
男 
註冊時間
2011-8-10 
最後登錄
2024-8-14 
12#
發表於 2016-1-7 23:21 | 只看該作者
回復 11# GBKEE


    複製~貼上  囧

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
13#
發表於 2016-1-8 08:48 | 只看該作者
本帖最後由 yen956 於 2016-1-8 09:00 編輯

Sorry,終於了解你的需求.
是不是這個意思?試試看:
  1. ' 本VBA請放在Sheet(1), 不要放在 Module1
  2. ' 請先手動調整你所需要的格式, 再執行本VBA
  3. ' 姓名放在 [J21:J23](請先調好姓名格式, 且姓名請空白)
  4. ' 時間放在 [H21:I23](請先調好時間格式, 並填入時間)
  5. ' 若將姓名、時間格式改別處, 下列相關[位址]請修改
  6. Sub TESTx()
  7.     Dim dV As Object, d0 As Object, dX As Object, E
  8.     Set dV = CreateObject("Scripting.Dictionary")
  9.     Set d0 = CreateObject("Scripting.Dictionary")
  10.     Set dX = CreateObject("Scripting.Dictionary")
  11.    
  12.     '1. 完全清除輸出區(包含內容、格式等)
  13.     [H13:BE15].Clear
  14.    
  15.     '2. 欄B的姓名分類放入Dictionary中
  16.        For Each E In Range("B2", "B" & [B65536].End(xlUp).Row)
  17.         If E.Offset(0, 1) = "" Then GoTo Next1:
  18.         If E.Offset(0, 1) = "V" Then dV.Item(E) = "": GoTo Next1:
  19.         If E.Offset(0, 1) = "O" Then d0.Item(E) = "": GoTo Next1:
  20.         If E.Offset(0, 1) = "X" Then dX.Item(E) = ""
  21. Next1:
  22.     Next
  23.    
  24.     '3. 複製姓名格式(重建姓名格式)
  25.     [J21:J23].Copy [H13].Resize(1, dV.Count)
  26.     [J21:J23].Copy [H13].Offset(0, dV.Count + 2).Resize(1, d0.Count)
  27.     [J21:J23].Copy [H13].Offset(0, dV.Count + d0.Count + 4).Resize(1, dX.Count)
  28.    
  29.     '4. 開始輸出姓名
  30.     [H13].Resize(1, 40) = ""
  31.     [H13].Resize(1, dV.Count) = dV.Keys
  32.     [H13].Offset(0, dV.Count + 2).Resize(1, d0.Count) = d0.Keys
  33.     [H13].Offset(0, dV.Count + 2 + d0.Count + 2).Resize(1, dX.Count) = dX.Keys
  34.    
  35.     '5. 複製時間
  36.     [H21:I23].Copy [H13].Offset(0, dV.Count)
  37.     [H21:I23].Copy [H13].Offset(0, dV.Count + 2 + d0.Count)
  38. End Sub
複製代碼
test.gif

TOP

074063

帖子
129 
主題
47 
精華
0 
積分
206 
點名
0  
作業系統
7 
軟體版本
2007 
閱讀權限
20 
性別
男 
註冊時間
2011-8-10 
最後登錄
2024-8-14 
14#
發表於 2016-1-9 23:17 | 只看該作者
回復 13# yen956


    感謝yen956大大, 解答滿合乎需求

    本以為程序會很複雜, 所以想說各類別中間空2格再自行剪貼上去

    小弟有個問題, 如果我的類別有3~4組, 則區分時間皆不同的話

    比如在【O】類別前時間為17:20~19:20, 在【X】類別前時間為17:20~18:20....

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
15#
發表於 2016-1-10 13:43 | 只看該作者
回復 14# 074063
假設如下圖:

則
    '5. 複製時間
    [H21:I23].Copy [H13].Offset(0, dV.Count)   '時間及格式1 的位址
    [H25:I27].Copy [H13].Offset(0, dV.Count + 2 + d0.Count)   '時間及格式2 的位址

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
16#
發表於 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

074063

帖子
129 
主題
47 
精華
0 
積分
206 
點名
0  
作業系統
7 
軟體版本
2007 
閱讀權限
20 
性別
男 
註冊時間
2011-8-10 
最後登錄
2024-8-14 
17#
發表於 2016-1-10 15:42 | 只看該作者
本帖最後由 074063 於 2016-1-10 15:44 編輯

回復 16# GBKEE


    假如類別依序有【V】【O】【X】,  今日key in時只有【V】【X】2類, 而【O】從缺

    在程式碼內是否能判斷不要輸出【O】類別的時間

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
18#
發表於 2016-1-11 17:47 | 只看該作者
  1. ' 本VBA請放在Sheet(1), 不要放在 Module1
  2. ' 下列兩列 ******** 之間請先調調好, 再執行本VBA
  3. Sub TEST3()
  4.     Dim I As Integer, J As Integer, Col As Integer
  5.     Dim arST, arET, arKind
  6.     ''***********************
  7.     Dim ndx(10) As Integer, cnt(10) As Integer          '多寫一點備用, 沒用到也沒關係
  8.     arKind = Array("X", "O", "V", "◎", "＊")                  '可增減, 沒用到也沒關係
  9.     '符號排列順序, 與將來的輸出順有關
  10.     arST = Array("17:20", "17:21", "17:22", "17:23")    '起始時間, 最多只能比"V,O,X,◎,＊"少1
  11.     arET = Array("19:20", "19:21", "19:22", "19:23")    '結束時間, 最多只能比"V,O,X,◎,＊"少1
  12.     ''***********************
  13.     Col = 8      'H=8, 姓名輸出位置在 [H13]
  14.    
  15.     '1. 完全清除輸出區(包含內容、格式等)
  16.     [H12:IV15].Clear
  17.    
  18.     '2. 重建時間
  19.     For I = 0 To UBound(arKind) - 1
  20.         cnt(I) = Application.CountIf(Range("C2", "C" & [C65536].End(xlUp).Row), arKind(I))
  21.         If cnt(I) > 0 Then
  22.             ndx(I) = Col
  23.             Col = Col + cnt(I)
  24.             If I <> UBound(arKind) - 2 Then
  25.                 For J = 13 To 15
  26.                     Cells(J, Col).Resize(1, 2).Merge   '時間格合併
  27.                     Cells(J, Col).HorizontalAlignment = xlCenter
  28.                 Next
  29.                 Cells(13, Col) = arST(I)            '起始時間在第13列
  30.                 Cells(14, Col) = "~"                '"~" 號在第14列
  31.                 Cells(14, Col).Orientation = -90    '文字方向→右轉90度(錄來的)
  32.                 Cells(15, Col) = arET(I)            '結束時間在第15列
  33.                 '如需其他格式, 請自行錄製再選用貼上(無須全部照抄)
  34.             End If
  35.             Col = Col + 2
  36.         End If
  37.     Next
  38.    
  39.     '3. 開始輸出姓名
  40.     For Each E In Range("B2", "B" & [B65536].End(xlUp).Row)
  41.         If E.Offset(0, 1) = "" Then GoTo Next1:
  42.         For I = 0 To UBound(arKind) - 1
  43.             If E.Offset(0, 1) = arKind(I) Then
  44.                 Cells(12, ndx(I)) = arKind(I)    '顯示標記(因有些符號你不想用, 故加註才會清楚), 可註解掉
  45.                 Cells(13, ndx(I)) = E
  46.                 Cells(13, ndx(I)).Resize(3, 1).Merge  '姓名格合併
  47.                 Cells(13, ndx(I)).Orientation = xlVertical   '文字方向→垂直排列
  48.                 ndx(I) = ndx(I) + 1
  49.                 GoTo Next1:
  50.             End If
  51.         Next
  52. Next1:
  53.     Next
  54. End Sub
複製代碼
回復 17# 074063

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
19#
發表於 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

        靜思自在 : 地上種了菜，就不易長草；心中有善，就不易生惡。
12
返回列表 上一主題