不同名稱隱藏

myleoyes

各位前輩你們好!
         前輩!!需求如動畫所示!
         因為欄數不段增加所以不能用錄製方式
         請問Sub 分析隱藏() 資料隱藏() Sub 資料來源() Sub 關係隱藏()程式為何?
         請知道的前輩,不吝賜教謝謝再三!!

GBKEE

回復 1# myleoyes

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     Application.EnableEvents = False
   
3.     If Target(1).Row = 2 Then           '在第2列
   
4.          Select Case Target(1).Column
   
5.         Case 1
   
6.               With ActiveWindow         '移除視窗分割
   
7.                 .SplitColumn = 0
   
8.                 .SplitRow = 0
   
9.             End With
   
10.             Cells.EntireColumn.Hidden = True
    
11.             [A1:F1].Cells.EntireColumn.Hidden = False
    
12.             [A1].Select
    
13.         Case 2 To 5                     'B2:E2
    
14.             隱藏 Target(1)
    
15.     End Select
    
16.     End If
    
17.     Application.EnableEvents = True
    
18. End Sub
    
19. 
    
20. Sub 隱藏(xLRng As Range)
    
21.     Dim Rng As Range, xF As Range
    
22.     Set Rng = Range("A2, F2" )
    
23.     Cells.EntireColumn.Hidden = False
    
24.     Set xF = Rows(2).Find(xLRng, LOOKAT:=xlPart, LookIn:=xlValues)   '尋找
    
25.     Do
    
26.         Set Rng = Union(Rng, xF)
    
27.         Set xF = Rows(2).FindNext(xF)
    
28.     Loop While xLRng.Address <> xF.Address  '一直到是第一尋找到的位置
    
29.     Cells.EntireColumn.Hidden = True
    
30.     Rng.EntireColumn.Hidden = False
    
31.     Rng.Select
    
32.     With ActiveWindow
    
33.         .SplitColumn = 6
    
34.         .SplitRow = 2
    
35.         .FreezePanes = True
    
36.     End With
    
37. End Sub

複製代碼

luhpro

各位前輩你們好!
         前輩!!需求如動畫所示!
         因為欄數不段增加所以不能用錄製方式
       ...
myleoyes 發表於 2012-8-29 12:03

1. Sub 分析隱藏()
   
2.     Dim iCols%, iI%, vCol
   
3.   
   
4.     [B3].Select
   
5.     ActiveWindow.FreezePanes = False
   
6.     iCols = Cells(2, Columns.Count).End(xlToLeft).Column
   
7.     Set vCol = Range(Cells(3), Cells(5))
   
8.     iI = 8
   
9.     Do
   
10.     Set vCol = Application.Union(vCol, Range(Cells(iI), Cells(iI + 2)))
    
11.     iI = iI + 4
    
12.     Loop Until iI > iCols
    
13.     vCol.EntireColumn.Hidden = True
    
14.    
    
15.     '[C:E,H:J,L:N,P:R,T:V,X:Z].EntireColumn.Hidden = True
    
16.    
    
17.     [G3].Select
    
18.     ActiveWindow.FreezePanes = True
    
19. End Sub
    
20. Sub 資料隱藏()
    
21.     Dim iCols%, iI%, vCol
    
22.   
    
23.     [B3].Select
    
24.     ActiveWindow.FreezePanes = False
    
25.     iCols = Cells(2, Columns.Count).End(xlToLeft).Column
    
26.     Set vCol = Application.Union(Cells(2), Cells(4), Cells(5), Cells(7))
    
27.     iI = 9
    
28.     Do
    
29.     Set vCol = Application.Union(vCol, Range(Cells(iI), Cells(iI + 2)))
    
30.     iI = iI + 4
    
31.     Loop Until iI > iCols
    
32.     vCol.EntireColumn.Hidden = True
    
33.    
    
34.     '[B:B,D:E,G:G,I:K,M:O,Q:S,U:W,Y:AA].EntireColumn.Hidden = True
    
35.    
    
36.     [H3].Select
    
37.     ActiveWindow.FreezePanes = True
    
38. End Sub

複製代碼

其他的只要參照上述程式內容適當的套用即可完成,
這裡就不再列出來囉.

myleoyes

回復 3# luhpro
  前輩!
       這正是小弟所需謝謝再三!!

myleoyes

回復 2# GBKEE
良師!謝謝!!程式在隱藏時少了1欄 (點選欄)
            展開時無法全開,同時沒有凍結窗格
            如動畫所示!請再修改一下辛苦囉!!謝謝再三!

GBKEE

回復 5# myleoyes
再試試看

1. Sub 隱藏(xLRng As Range)
   
2.     Dim Rng As Range, xF As Range
   
3.     Set Rng = Range("A2, F2")
   
4.     Cells.EntireColumn.Hidden = False
   
5.     Set xF = Rows(2).Find(xLRng, xLRng.Offset(, -1), LOOKAT:=xlPart, LookIn:=xlValues) '尋找
   
6.     Do
   
7.         Set Rng = Union(Rng, xF)
   
8.         Set xF = Rows(2).FindNext(xF)
   
9.     Loop While xLRng.Address <> xF.Address  '一直到是第一尋找到的位置
   
10.     Cells.EntireColumn.Hidden = True
    
11.     Rng.EntireColumn.Hidden = False
    
12.     Rng.Select
    
13.     With ActiveWindow
    
14.         .SplitColumn = 6
    
15.         .SplitRow = 2
    
16.         .FreezePanes = True
    
17.     End With
    
18. End Sub

複製代碼

myleoyes

回復 6# GBKEE
良師!謝謝!!程式修改如下
    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.EnableEvents = False
    If Target(1).Row = 2 Then
         Select Case Target(1).Column
        Case 1
           [A:E].Cells.EntireColumn.Hidden = False  '增加此列
              With ActiveWindow
                .SplitColumn = 1  '修改處
                .SplitRow = 2  '修改處
                .FreezePanes = True
            End With
            [A:IV].Cells.EntireColumn.Hidden = True   '修改處
            [A:IV].Cells.EntireColumn.Hidden = False  '修改處
            [A1].Select
        Case 2 To 5
            隱藏 Target(1)
    End Select
    End If
    Application.EnableEvents = True
End Sub
            另有一程式(點選下拉)如附檔案!請再幫忙一下辛苦囉!!謝謝再三!

GBKEE

回復 7# myleoyes
是這樣嗎?

1. Sub 數據()
   
2.     zz = Application.InputBox("輸入數據", "請輸入修正數據", Type:=1)
   
3.     If zz = 0 Then Exit Sub
   
4.     ActiveCell = zz: [D1] = ""
   
5.     Selection.Resize(2).AutoFill Range(Selection, Cells([B100].End(3).Row, Selection.Column)), Type:=xlFillDefault
   
6.     [D1] = "'分析"
   
7. End Sub

複製代碼

myleoyes

回復 8# GBKEE
良師! 謝謝!!程式修改如下辛苦囉!!謝謝再三!
Sub 數據()
    zz = Application.InputBox("輸入數據", "請輸入修正數據", Type:=1)
    If zz = 0 Then Exit Sub
    ActiveCell = zz: [D1] = ""
    Selection.AutoFill Range(Selection, Cells([B100].End(3).Row, Selection.Column)), Type:=xlFillDefault  '修改處
    [D1] = "'分析"
End Sub

GBKEE

回復 9# myleoyes
有幸會解答是不辛苦的,只是不明嘹問題很辛苦啦.要修改什麼,可以用文字敘述嗎?