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

074063

如附件, 請教各位大大

下載 (173.98 KB)

2016-1-5 01:02

Book1.rar (9.08 KB)

下載次數: 7

2016-1-5 01:02

GBKEE

回復 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

複製代碼

准提部林

另個參考：

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

http://blog.xuite.net/hcm19522/twblog/371048822

yen956

我也試試看:

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

回復 3# 准提部林


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

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

下載 (67.09 KB)

2016-1-5 20:19

yen956

回復 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

回復 7# yen956


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

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

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

    Book2.rar (28.13 KB)

下載次數: 13

2016-1-6 00:03

yen956

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

又, 輸出目的地的格式宜保持一致, 中間又插入時間等格式,
會造成整個表格沒有彈性, 不能增加或減少各組名單的調整.
表格越簡單越好處理

准提部林

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

只能建議以〔按鈕〕執行，不要妄用change事件，造成檔案操作的困擾或效率！！！