返回列表 上一主題 發帖

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

本帖最後由 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
複製代碼

TOP

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

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

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

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

TOP

本帖最後由 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

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

  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

        靜思自在 : 發脾氣是短暫的發瘋。
返回列表 上一主題