麻辣家族討論版版 - Powered by Discuz! Board

標題: 不同名稱隱藏 [打印本頁]

作者: myleoyes 時間: 2012-8-29 12:03 標題: 不同名稱隱藏

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

作者: GBKEE 時間: 2012-8-29 21:27

本帖最後由 GBKEE 於 2012-8-30 14:36 編輯

回復 1# myleoyes

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
If Target(1).Row = 2 Then '在第2列
Select Case Target(1).Column
Case 1
With ActiveWindow '移除視窗分割
.SplitColumn = 0
.SplitRow = 0
End With
Cells.EntireColumn.Hidden = True
[A1:F1].Cells.EntireColumn.Hidden = False
[A1].Select
Case 2 To 5 'B2:E2
隱藏 Target(1)
End Select
End If
Application.EnableEvents = True
End Sub
Sub 隱藏(xLRng As Range)
Dim Rng As Range, xF As Range
Set Rng = Range("A2, F2" )
Cells.EntireColumn.Hidden = False
Set xF = Rows(2).Find(xLRng, LOOKAT:=xlPart, LookIn:=xlValues) '尋找
Do
Set Rng = Union(Rng, xF)
Set xF = Rows(2).FindNext(xF)
Loop While xLRng.Address <> xF.Address '一直到是第一尋找到的位置
Cells.EntireColumn.Hidden = True
Rng.EntireColumn.Hidden = False
Rng.Select
With ActiveWindow
.SplitColumn = 6
.SplitRow = 2
.FreezePanes = True
End With
End Sub

複製代碼

作者: luhpro 時間: 2012-8-29 21:33

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

Sub 分析隱藏()
Dim iCols%, iI%, vCol
[B3].Select
ActiveWindow.FreezePanes = False
iCols = Cells(2, Columns.Count).End(xlToLeft).Column
Set vCol = Range(Cells(3), Cells(5))
iI = 8
Do
Set vCol = Application.Union(vCol, Range(Cells(iI), Cells(iI + 2)))
iI = iI + 4
Loop Until iI > iCols
vCol.EntireColumn.Hidden = True
'[C:E,H:J,L:N,P:R,T:V,X:Z].EntireColumn.Hidden = True
[G3].Select
ActiveWindow.FreezePanes = True
End Sub
Sub 資料隱藏()
Dim iCols%, iI%, vCol
[B3].Select
ActiveWindow.FreezePanes = False
iCols = Cells(2, Columns.Count).End(xlToLeft).Column
Set vCol = Application.Union(Cells(2), Cells(4), Cells(5), Cells(7))
iI = 9
Do
Set vCol = Application.Union(vCol, Range(Cells(iI), Cells(iI + 2)))
iI = iI + 4
Loop Until iI > iCols
vCol.EntireColumn.Hidden = True
'[B:B,D:E,G:G,I:K,M:O,Q:S,U:W,Y:AA].EntireColumn.Hidden = True
[H3].Select
ActiveWindow.FreezePanes = True
End Sub

複製代碼

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

作者: myleoyes 時間: 2012-8-30 12:18

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

作者: myleoyes 時間: 2012-8-30 12:25

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

作者: GBKEE 時間: 2012-8-30 14:41

回復 5# myleoyes
再試試看

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

複製代碼

作者: myleoyes 時間: 2012-8-31 12:22

回復 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 時間: 2012-8-31 17:32

回復 7# myleoyes
是這樣嗎?

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

複製代碼

作者: myleoyes 時間: 2012-8-31 21:36

回復 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 時間: 2012-9-1 14:32

本帖最後由 GBKEE 於 2012-9-1 14:37 編輯

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

作者: myleoyes 時間: 2012-9-3 21:24

回復 10# GBKEE
良師! 謝謝!!這個點選下拉程式已經修改可以囉!你可能誤會還需要修改
抱歉又麻煩你謝謝再三!!

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