074063

帖子: 129
主題: 47
精華: 0
積分: 206
點名: 1
作業系統: 7
軟體版本: 2007
閱讀權限: 20
性別: 男
註冊時間: 2011-8-10
最後登錄: 2024-8-14

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2016-1-5 01:02 | 只看該作者

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

如附件, 請教各位大大

Book1.rar (9.08 KB)

樓主熱帖

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 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-5 09:08 | 只看該作者

回復 1# 074063
試試看

Option Explicit
Sub Ex()
Dim D As Object, i As Integer, Ar(), E As Variant
Set D = CreateObject("SCRIPTING.DICTIONARY") '字典物件
i = 2
Do While Range("B" & i) <> "" 'B2開始直到B欄沒資料
If Range("C" & i) <> "" Then
If Not D.exists(Range("C" & i).Text) Then '字典物件的key不存在
D(Range("C" & i).Text) = Array(Range("b" & i)) '這的key的項目為..
Else '字典物件的key已存在
Ar = D(Range("C" & i).Text) 'Ar=字典物件的key的項目
ReDim Preserve Ar(UBound(Ar) + 1) '陣列擴充一元素
Ar(UBound(Ar)) = Range("b" & i) '陣列最後元素的值
D(Range("C" & i).Text) = Ar '字典物件的key的項目=Ar
End If
End If
i = i + 1
Loop
i = 1
With Range("E4")
For Each E In D.ITEMS '字典物件的項目
.Cells(1, i).Resize(1, UBound(E) + 1) = E
i = i + UBound(E) + 3
Next
End With
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2833
主題: 10
精華: 0
積分: 2889
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-11

3^#

發表於 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

TOP

hcm19522

大學生 Rank: 4

帖子: 1387
主題: 4
精華: 0
積分: 1397
點名: 0
作業系統: WIN
軟體版本: 2007
閱讀權限: 50
性別: 男
註冊時間: 2015-9-11
最後登錄: 2024-11-7

熱烈參與勳章

4^#

發表於 2016-1-5 14:32 | 只看該作者

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

TOP

yen956

高中生 Rank: 3 Rank: 3

帖子: 522
主題: 36
精華: 1
積分: 603
點名: 0
作業系統: win xp sp3
軟體版本: Office 2003
閱讀權限: 50
性別: 男
註冊時間: 2012-12-13
最後登錄: 2021-7-11

5^#

發表於 2016-1-5 15:16 | 只看該作者

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

我也試試看:

Sub TEST1()
Dim dv As Object, d0 As Object, dx As Object, E
Set dv = CreateObject("Scripting.Dictionary")
Set d0 = CreateObject("Scripting.Dictionary")
Set dx = CreateObject("Scripting.Dictionary")
For Each E In Range([B2], [B65536].End(xlUp))
If E.Offset(0, 1) = "V" Then dv.Item(E) = ""
If E.Offset(0, 1) = "O" Then d0.Item(E) = ""
If E.Offset(0, 1) = "X" Then dx.Item(E) = ""
Next
[E4].Resize(1, 40) = ""
[E4].Resize(1, dv.Count) = dv.Keys
[E4].Offset(0, dv.Count + 2).Resize(1, d0.Count) = d0.Keys
[E4].Offset(0, dv.Count + 2 + d0.Count + 2).Resize(1, dx.Count) = dx.Keys
End Sub

複製代碼

TOP

074063

中學生 Rank: 2

帖子: 129
主題: 47
精華: 0
積分: 206
點名: 1
作業系統: 7
軟體版本: 2007
閱讀權限: 20
性別: 男
註冊時間: 2011-8-10
最後登錄: 2024-8-14

6^#

發表於 2016-1-5 20:19 | 只看該作者

回復 3# 准提部林

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

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

TOP

yen956

高中生 Rank: 3 Rank: 3

帖子: 522
主題: 36
精華: 1
積分: 603
點名: 0
作業系統: win xp sp3
軟體版本: Office 2003
閱讀權限: 50
性別: 男
註冊時間: 2012-12-13
最後登錄: 2021-7-11

7^#

發表於 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

TOP

074063

中學生 Rank: 2

帖子: 129
主題: 47
精華: 0
積分: 206
點名: 1
作業系統: 7
軟體版本: 2007
閱讀權限: 20
性別: 男
註冊時間: 2011-8-10
最後登錄: 2024-8-14

8^#

發表於 2016-1-6 00:03 | 只看該作者

回復 7# yen956

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

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

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

Book2.rar (28.13 KB)

TOP

yen956

高中生 Rank: 3 Rank: 3

帖子: 522
主題: 36
精華: 1
積分: 603
點名: 0
作業系統: win xp sp3
軟體版本: Office 2003
閱讀權限: 50
性別: 男
註冊時間: 2012-12-13
最後登錄: 2021-7-11

9^#

發表於 2016-1-6 12:12 | 只看該作者

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

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

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

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2833
主題: 10
精華: 0
積分: 2889
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-11

10^#

發表於 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事件，造成檔案操作的困擾或效率！！！

TOP