Below is an example I found to hide/open complete rows in Excel with a doubleclick.
It works for a few lines but if I want to do this for 100 lines it's a terrible job.
Is it possible to make this more code-friendly?
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Address(0, 0) = "A9" Then
Cancel = True
Rows("10:15").Hidden = Not Rows("10:15").Hidden
End If
If Target.Address(0, 0) = "A16" Then
Cancel = True
Rows("17:22").Hidden = Not Rows("17:22").Hidden
End If
If Target.Address(0, 0) = "A23" Then
Cancel = True
Rows("24:29").Hidden = Not Rows("24:29").Hidden
End If
If Target.Address(0, 0) = "A30" Then
Cancel = True
Rows("31:36").Hidden = Not Rows("31:36").Hidden
End If
If Target.Address(0, 0) = "A37" Then
Cancel = True
Rows("38:43").Hidden = Not Rows("38:43").Hidden
End If
If Target.Address(0, 0) = "A44" Then
Cancel = True
Rows("45:50").Hidden = Not Rows("45:50").Hidden
End If
Try this:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column <> 1 Then Exit Sub
Dim r As Long
r = Target.Row
If (r - 2) Mod 7 = 0 And r > 2 Then
Rows(r + 1).Resize(6).Hidden = Not (Rows(r + 1).Resize(6).Hidden)
Cancel = True
End If
End Sub
You can use this code
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Row < 9 then Exit Sub
If (Target.Row - 2) Mod 7 = 0 Then 'e.g. 9, 16, 23, 30
hideRows Target.Row + 1
End If
End Sub
Private Sub hideRows(startRow As Long)
With Me.Rows(startRow).Resize(6)
.Hidden = Not .Hidden
End With
End Sub
UPDATE after #foxfires comment:
If you like the expand/collapse idea, you can use this code:
Public Sub groupRows(ws As Worksheet)
Dim c As Range
Set c = ws.Cells(9, 1)
While LenB(c.Text) > 0
c.Offset(1).Resize(6).EntireRow.Group
Set c = c.Offset(7)
Wend
With ws.Outline
.SummaryRow = xlSummaryAbove
.ShowLevels 1
End With
End Sub
Related
Want sequence to start on Cell A4. so that A4 is 1, A5 is 2 et al to A1004 = 1004
Tried changing [Range("A" & I)..] to [Range("A4" & I)..]
Tried changing I=4
Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Integer
I = 1
Application.EnableEvents = False
For I = 1 To 1000
Range("A" & I).Value = I
Next
Range("A1010").Value = ""
Application.EnableEvents = True
End Sub
Sub Worksheet_Change(ByVal Target As Range)
Dim I As Integer
Set startRng = Cells(4, 1)
Application.EnableEvents = False
For I = 0 To 999
startRng.Offset(I, 0) = I
Next
Range("A1010").Value = ""
Application.EnableEvents = True
End Sub
I want to enable both of these worksheet_change event procedures in same sheet.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, V As Variant, N As Long
Set r = Intersect(Range("H6"), Target)
If r Is Nothing Then Exit Sub
V = r(1).Value
Application.EnableEvents = False
N = Cells(Rows.Count, "K").End(xlUp).Row
If IsEmpty(Range("K11").Value) = True Then
Cells(N + 10, 11).Value = V
Else
Cells(N + 1, 11).Value = V
End If
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, V As Variant, N As Long
Set r = Intersect(Range("J6"), Target)
If r Is Nothing Then Exit Sub
V = r(1).Value
Application.EnableEvents = False
N = Cells(Rows.Count, "P").End(xlUp).Row
If IsEmpty(Range("K16").Value) = True Then
Cells(N + 10, 16).Value = V
Else
Cells(N + 1, 16).Value = V
End If
Application.EnableEvents = True
End Sub
Combine them into one event. You can replace my msgbox code with what you want to happen when a particular cell is triggered.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r1 As Range
Dim r2 As Range, V As Variant, N As Long
Set r1 = Range("H6")
Set r2 = Range("J6")
If Application.Intersect(Target, Union(r1, r2)) Is Nothing Then Exit Sub
Application.EnableEvents = False
If Target.Address(0, 0) = "H6" Then
MsgBox "H6 triggered" 'your H6 code
ElseIf Target.Address(0, 0) = "J6" Then
MsgBox "J6 triggered" 'your J6 code
Else
MsgBox "Unexpected error"
End If
Application.EnableEvents = True
End Sub
With your code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r1 As Range
Dim r2 As Range, V As Variant, N As Long
Set r1 = Range("H6")
Set r2 = Range("J6")
If Application.Intersect(Target, Union(r1, r2)) Is Nothing Then Exit Sub
Application.EnableEvents = False
If Target.Address(0, 0) = "H6" Then
V = r1(1).Value
N = Cells(Rows.Count, "K").End(xlUp).Row
If IsEmpty(Range("K11").Value) = True Then
Cells(N + 10, 11).Value = V
Else
Cells(N + 1, 11).Value = V
End If
ElseIf Target.Address(0, 0) = "J6" Then
V = r2(1).Value
N = Cells(Rows.Count, "P").End(xlUp).Row
If IsEmpty(Range("K16").Value) = True Then
Cells(N + 10, 16).Value = V
Else
Cells(N + 1, 16).Value = V
End If
Else
MsgBox "Unexpected error"
End If
Application.EnableEvents = True
End Sub
how to adjust this code, so that it works for the whole column and not only for one cell?
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Application.EnableEvents = False
With Target
If .Address = Range("A11:A1").Address Then
Select Case .Value
Case "Excel"
.Value = "Word"
Case "Word"
.Value = "Outlook"
Case "Outlook"
.Value = "Excel"
Case Else
.Value = "Word"
End Select
End If
End With
Range("A2").Select
Application.EnableEvents = True
End Sub
Thank you very much!
Jeame
As follows but you are setting up a recurring chain if you select A2 at the end and your target is column A. I have removed.
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Application.EnableEvents = False
If Target.Column = 1 Then 'example column A
With Target
Select Case .Value
Case "Excel"
.Value = "Word"
Case "Word"
.Value = "Outlook"
Case "Outlook"
.Value = "Excel"
Case Else
.Value = "Word"
End Select
End With
End If
Application.EnableEvents = True
End Sub
Edit:
Following on from a change to requirements please see a re-write of your code. The Test sub is just for testing the event.
Option Explicit
Private Sub Test()
Call Worksheet_BeforeDoubleClick(Selection, True)
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column = 2 Then
Dim var As Long
Dim targetRange As Range
var = Target.Row
Set targetRange = ActiveSheet.Range("A" & var & ":B" & var) '2 columns of interest for row that was triggered
With targetRange.Columns(2)
Select Case LCase(.Value) 'i.e. column B's value. Add add change to lowercase so test always matches
Case "active"
targetRange.Interior.ColorIndex = 16
.Value = "Finished"
Case "wip"
targetRange.Interior.ColorIndex = 2
.Value = "Done"
End Select
End With
End If
End Sub
Too complicated solution for me. Below is the code, which should work similar but with double click. Before I only did data valiation - listbox with two options. But somehow it does not work to me.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Var = Target.Row
var2 = "b" + Var
If (Target.Column = 2) Then
If (Range(var2).Value = "Active") Then
var2 = "a" + Var
Range(var2).Interior.ColorIndex = 16
var2 = "b" + Var
Range(var2).Interior.ColorIndex = 16
Range(var2).Value = "Finished"
Else
Var = "b" + Var
If (Range(var2).Value = "WIP") Then
var2 = "a" + Var
Range(var2).Interior.ColorIndex = 2
var2 = "b" + Var
Range(var2).Interior.ColorIndex = 2
Range(var2).Value = "DONE"
End If
End If
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
I add a date picker 12.0 on Sheet 1 and would like to have it working across sheet 2 and sheet 3 as well.
The below code only works on column 3 and column 6 of sheet 1, but when I click on the column 3 and column 6 in sheet 2 or sheet 3, no date picker shows up.
Please help, thanks a bunch!
Private Sub Calendar1_Click()
Selection.Value = Calendar1.Value
Calendar1.Visible = False
Calendar1.Value = Date
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column <> 3 And Target.Column <> 6 Then Calendar1.Visible = fales: Exit Sub
Calendar1.Top = (Target.Row - 1) * 16.5
Calendar1.Top = ActiveCell.Top
Calendar1.Left = ActiveCell.Left + 80
Calendar1.Visible = True
End Sub
Assuming Calendar1 is available to the other worksheets then include your event trigger in the Workbook_SheetSelectionChange as below:
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Column <> 3 And Target.Column <> 6 Then Calendar1.Visible = False: Exit Sub
Calendar1.Top = (Target.Row - 1) * 16.5
Calendar1.Top = Target.Top
Calendar1.Left = Target.Left + 80
Calendar1.Visible = True
End Sub
Regards,
Place this code in Workbook Module
Option Explicit
Private Sub Calendar1_Click()
Selection.Value = Calendar1.Value
Calendar1.Visible = False
Calendar1.Value = Date
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Column <> 3 And Target.Column <> 6 Then
Calendar1.Visible = False
Exit Sub
Else
Calendar1.Top = (Target.Row - 1) * 16.5
Calendar1.Top = ActiveCell.Top
Calendar1.Left = ActiveCell.Left + 80
Calendar1.Visible = True
End If
End Sub
I have a code
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim ltr, rNum, AlphaLtrs
AlphaLtrs = "ABCDEFGHIGKLMNOPQRSTUVWXYZ"
selLtr = Application.RoundUp(Rnd() * 26, 0)
ltr = Mid(AlphaLtrs, selLtr, 1)
rNum = Application.RoundUp(Rnd() * 999999, 0)
ActiveCell.Value = ltr & rNum
Target.Offset(0, 1).Select
End Sub
what I need is, to change the doubleclick function into Enter
and also if possible can I add the value of Column A in to the generated code beginning like Jeans-A545145
This adds a value to any cell that selected in column B, as long as only one cell is selected. Paste it into the code module for that sheet:
EDIT: Not sure if this is what you want, but now only does it if Target cell is empty:
EDIT 2: Woops, found a bug in the IF. If you select more than one cell, it errors on the IF Target.Value = "" part. I separated that into a second IF:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ltr, rNum, AlphaLtrs, selLtr
If Not Intersect(Target, Me.Columns(2)) Is Nothing And _
Target.Cells.Count = 1 Then
If Target.Value = "" Then
AlphaLtrs = "ABCDEFGHIGKLMNOPQRSTUVWXYZ"
selLtr = Application.RoundUp(Rnd() * 26, 0)
ltr = Mid(AlphaLtrs, selLtr, 1)
rNum = Application.RoundUp(Rnd() * 999999, 0)
Target.Value = Me.Range("A" & Target.Row) & "-" & ltr & rNum
End If
End If
End Sub
Perhaps:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
Dim ltr, rNum, AlphaLtrs
AlphaLtrs = "ABCDEFGHIGKLMNOPQRSTUVWXYZ"
selLtr = Application.RoundUp(Rnd() * 26, 0)
ltr = Mid(AlphaLtrs, selLtr, 1)
rNum = Application.RoundUp(Rnd() * 999999, 0)
ActiveCell.Value = ltr & rNum
Target.Offset(0, 1).Select
Application.EnableEvents = True
End Sub