Board logo

標題: 如何參照資料將勾選項指定至範圍儲存格 [打印本頁]
作者: 074063    時間: 2016-1-5 01:02     標題: 如何參照資料將勾選項指定至範圍儲存格

如附件, 請教各位大大
[attach]23040[/attach]
[attach]23041[/attach]
作者: GBKEE    時間: 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
複製代碼
作者: 准提部林    時間: 2016-1-5 10:56

另個參考：

Sub TEST()
Dim xD, T, TT, xR As Range
Set xD = CreateObject("Scripting.Dictionary")
For Each xR In Range([B2], [B65536].End(xlUp))
　　T = xR(1, 2): If T <> "" Then xD(T) = xD(T) & "|" & xR
Next
　
Set xR = [E4]: xR.Resize(1, 100) = ""
For Each T In Array("V", "O", "X")
　　If xD(T) = "" Then GoTo 101
　　TT = Split(Mid(xD(T), 2), "|")
　　xR.Resize(1, UBound(TT) + 1) = TT
　　Set xR = xR(1, UBound(TT) + 4)
101: Next
End Sub
作者: hcm19522    時間: 2016-1-5 14:32

http://blog.xuite.net/hcm19522/twblog/371048822
作者: yen956    時間: 2016-1-5 15:16

本帖最後由 yen956 於 2016-1-5 15:22 編輯

我也試試看:
  1. Sub TEST1()
  2.     Dim dv As Object, d0 As Object, dx As Object, E
  3.     Set dv = CreateObject("Scripting.Dictionary")
  4.     Set d0 = CreateObject("Scripting.Dictionary")
  5.     Set dx = CreateObject("Scripting.Dictionary")
  6.     For Each E In Range([B2], [B65536].End(xlUp))
  7.         If E.Offset(0, 1) = "V" Then dv.Item(E) = ""
  8.         If E.Offset(0, 1) = "O" Then d0.Item(E) = ""
  9.         If E.Offset(0, 1) = "X" Then dx.Item(E) = ""
  10.     Next
  11.     [E4].Resize(1, 40) = ""
  12.     [E4].Resize(1, dv.Count) = dv.Keys
  13.     [E4].Offset(0, dv.Count + 2).Resize(1, d0.Count) = d0.Keys
  14.     [E4].Offset(0, dv.Count + 2 + d0.Count + 2).Resize(1, dx.Count) = dx.Keys
  15. End Sub
複製代碼
作者: 074063    時間: 2016-1-5 20:19

回復 3# 准提部林


    感謝各位大大的解答, ^^

    小弟另請教如何把 E4:AG4 資料清空, 並每欄3列合併成一格儲存格, 且都無框線

[attach]23046[/attach]
作者: yen956    時間: 2016-1-5 21:26

回復 6# 074063
Sub test()
    Dim I As Integer, J As Integer
    For I = 5 To 33
        Cells(4, I).Resize(3, 1).Select
        With Selection
            .Merge
            For J = 1 To 4
                .Borders(J).LineStyle = xlNone
            Next
        End With
    Next
End Sub
作者: 074063    時間: 2016-1-6 00:03

回復 7# yen956


    謝yen956大大解答, 執行起來好像卡卡的

    感謝GBKEE、准提部林、hcm19522、yen956

    再附上檔案大大們幫忙..

   [attach]23048[/attach]
作者: yen956    時間: 2016-1-6 12:12

本帖最後由 yen956 於 2016-1-6 12:14 編輯

回復 8# 074063
Book2 的輸出範圍與Book1 的輸出範圍不同,
原 VAB 要套用到 Book2 上, 請將相關位址改一改,
(不論是公式或是VBA均如此)
以 5#F 我的VBA為例, 只要將
[E4] 改為 [H13], 即可正常

又, 輸出目的地的格式宜保持一致, 中間又插入時間等格式,
會造成整個表格沒有彈性, 不能增加或減少各組名單的調整.
表格越簡單越好處理
作者: 准提部林    時間: 2016-1-6 14:49

Sub 清除()
With Range("H13:H15")
　　　.UnMerge
　　　.ClearContents
　　　.Borders.LineStyle = xlNone
　　　.Merge
　　　.Copy Range("I13:AJ15")
End With
End Sub

只能建議以〔按鈕〕執行，不要妄用change事件，造成檔案操作的困擾或效率！！！
作者: GBKEE    時間: 2016-1-7 07:43

回復 8# 074063
17:20       
~       
19:20       
這時間的邏輯如何設定
作者: 074063    時間: 2016-1-7 23:21

回復 11# GBKEE


    複製~貼上  囧
作者: yen956    時間: 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
複製代碼
[attach]23060[/attach]
作者: 074063    時間: 2016-1-9 23:17

回復 13# yen956


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

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

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

    比如在【O】類別前時間為17:20~19:20, 在【X】類別前時間為17:20~18:20....
作者: yen956    時間: 2016-1-10 13:43

回復 14# 074063
假設如下圖:
[attach]23074[/attach]
則
    '5. 複製時間
    [H21:I23].Copy [H13].Offset(0, dV.Count)   '時間及格式1 的位址
    [H25:I27].Copy [H13].Offset(0, dV.Count + 2 + d0.Count)   '時間及格式2 的位址
作者: GBKEE    時間: 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
複製代碼
作者: 074063    時間: 2016-1-10 15:42

本帖最後由 074063 於 2016-1-10 15:44 編輯

回復 16# GBKEE


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

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

[attach]23075[/attach]
作者: yen956    時間: 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
作者: GBKEE    時間: 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
複製代碼




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