I am trying to make a sub that changes the months according to a dropdown list. So everytime I change the month in the dropdown C3, it should copy the right month from a different aleady prepared sheet. As a sub it works just fine, but as an event it doesn't. I am guessing it is a problem with the event and the select case. Any ideas?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim month As String
If Target.Address = Range("C3") Then
Range("A5:H27").Clear
month = Range("C3")
Select Case month
Case "Januar"
Workbooks("Timesheet").Worksheets("Input").Range("A3:A25").Copy Workbooks("Timesheet").Worksheets("Time Sheet").Range("A5")
Case "Februar"
Workbooks("Timesheet").Worksheets("Input").Range("B3:B25").Copy Workbooks("Timesheet").Worksheets("Time Sheet").Range("A5")
Case "März"
Workbooks("Timesheet").Worksheets("Input").Range("C3:C25").Copy Workbooks("Timesheet").Worksheets("Time Sheet").Range("A5")
Case "April"
Workbooks("Timesheet").Worksheets("Input").Range("D3:D25").Copy Workbooks("Timesheet").Worksheets("Time Sheet").Range("A5")
Case "Mai"
Workbooks("Timesheet").Worksheets("Input").Range("E3:E25").Copy Workbooks("Timesheet").Worksheets("Time Sheet").Range("A5")
Case "Juni"
Workbooks("Timesheet").Worksheets("Input").Range("F3:F25").Copy Workbooks("Timesheet").Worksheets("Time Sheet").Range("A5")
Case "Juli"
Workbooks("Timesheet").Worksheets("Input").Range("G3:G25").Copy Workbooks("Timesheet").Worksheets("Time Sheet").Range("A5")
Case "August"
Workbooks("Timesheet").Worksheets("Input").Range("H3:H25").Copy Workbooks("Timesheet").Worksheets("Time Sheet").Range("A5")
Case "September"
Workbooks("Timesheet").Worksheets("Input").Range("I3:I25").Copy Workbooks("Timesheet").Worksheets("Time Sheet").Range("A5")
Case "Oktober"
Workbooks("Timesheet").Worksheets("Input").Range("J3:J25").Copy Workbooks("Timesheet").Worksheets("Time Sheet").Range("A5")
Case "November"
Workbooks("Timesheet").Worksheets("Input").Range("K3:K25").Copy Workbooks("Timesheet").Worksheets("Time Sheet").Range("A5")
Case "Dezember"
Workbooks("Timesheet").Worksheets("Input").Range("L3:L25").Copy Workbooks("Timesheet").Worksheets("Time Sheet").Range("A5")
End Select
End If
End Sub
Please, copy the next code in the sheet code module where the drop down in discussion exists:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim month As String, copyRange As Range, wsI As Worksheet, wsTS As Worksheet
If Target.Address = Range("C3").Address Then
Set wsI = Workbooks("Timesheet").Worksheets("Input")
Set wsTS = Workbooks("Timesheet").Worksheets("Time Sheet")
Application.EnableEvents = False
Range("A5:H27").Clear
Application.EnableEvents = True
month = CStr(Target.Value)
Select Case month
Case "Januar"
Set copyRange = wsI.Range("A3:A25")
Case "Februar"
Set copyRange = wsI.Range("B3:B25")
Case "März"
Set copyRange = wsI.Range("C3:C25")
Case "April"
Set copyRange = wsI.Range("D3:D25")
Case "Mai"
Set copyRange = wsI.Range("E3:E25")
Case "Juni"
Set copyRange = wsI.Range("F3:F25")
Case "Juli"
Set copyRange = wsI.Range("G3:G25")
Case "August"
Set copyRange = wsI.Range("H3:H25")
Case "September"
Set copyRange = wsI.Range("I3:I25")
Case "Oktober"
Set copyRange = wsI.Range("J3:J25")
Case "November"
Set copyRange = wsI.Range("K3:K25")
Case "Dezember"
Set copyRange = wsI.Range("L3:L25")
End Select
If Not copyRange Is Nothing Then
copyRange.Copy wsTS.Range("A5")
Else
MsgBox Target.Value & " could not be used in Select Case..."
End If
End If
End Sub
Now change the values in "C3". If the event is not triggered, run the next code and try again:
Sub EventsEnabled
Application.EnableEvents = True
End Sub
If I could see the range in "different already prepared sheet", based on what the list validation is done and the months enumeration comes in logic order, the Select Case can be avoided and calculate the necessary range, according to the months string position in the list, in a single code line...
Edited:
Please, test the more compact code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim month As String, copyRange As Range, wsI As Worksheet, wsTS As Worksheet
Dim wsSpec As Worksheet, rngMonths As Range, mtch
If Target.Address = Range("C3").Address Then
Set wsI = Workbooks("Timesheet").Worksheets("Input")
Set wsTS = Workbooks("Timesheet").Worksheets("Time Sheet")
Set wsTS = Worksheets("the special sheet...") 'your special worksheet...
Application.EnableEvents = False
Range("A5:H27").Clear
Application.EnableEvents = True
month = CStr(Target.Value)
Set rngMonths = wsSpec.Range("A2:L2")
mtch = Application.match(month, rngMonths, 0)
If Not isserror(mtch) Then
Set rngCopy = wsTS.Range(wsTS.cells(3, mtch), wsTS.cells(25, mtch))
copyRange.Copy wsTS.Range("A5")
Else
MsgBox Target.Value & " could not be found in the months range..."
End If
Set rngCopy = sh.Range(sh.cells(3, mtch), sh.cells(25, mtch))
End If
End Sub
Not tested, of course, but this should be the logic. If something wrong, please tell me what error and on which line.
Now, I am leaving my office...
Related
I have code within a workbook that works exactly how I want it to, but I am looking for ways to increase its efficiency/speed. My thought would be to add a union for all blank rows and hide that range all at once. Can this be done?
Sub HideRws()
Dim Rng As Range, Cl As Range
With Sheet3
For Each Cl In .Range("A11:A60")
Cl.EntireRow.Hidden = Cl.Value = ""
Next Cl
For Each Rng In .Range("A71:A120, A131:A180, A190:A239").Areas
If Rng(1) = "" Then
Rng.Offset(-6).Resize(58).EntireRow.Hidden = True
Else
For Each Cl In Rng
Cl.EntireRow.Hidden = Cl.Value = ""
Next Cl
End If
Next Rng
End With
End Sub
I think this does the same thing:
Sub HideRows()
With Sheet3
.Range("A11:A60").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
For Each Rng In .Range("A71:A120, A131:A180, A190:A239").Areas
If Rng(1) = "" Then
Rng.Offset(-6).Resize(58).EntireRow.Hidden = True
Else
Rng.SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
End If
Next Rng
End With
End Sub
For some reason this Array isnt working! What could be wrong? Basically it is supposed to loop through every worksheet and give the same header to each worksheet.
WorksheetNames = Array("Sheet1", "Sheet2")
For Each ws In WorksheetNames
With Worksheets(ws)
.Range("F1").FormulaR1C1 = "PSTRIK"
.Range("A1").FormulaR1C1 = "PRECID"
.Range("C1").FormulaR1C1 = "PEXCH"
.Range("J1").FormulaR1C1 = "PQTY"
.Range("G1").FormulaR1C1 = "PCTYM"
.Range("D1").FormulaR1C1 = "PFC"
.Range("B1").FormulaR1C1 = "PACCT"
.Range("K1").FormulaR1C1 = "PPRTCP"
.Range("E1").FormulaR1C1 = "PSUBTY"
.Range("H1").FormulaR1C1 = "PSBCUS"
.Range("I1").FormulaR1C1 = "PBS"
End With
Next ws
I suspect something like this is what you're looking for:
Sub tgr()
Dim ws As Worksheet
Dim aHeaders As Variant
aHeaders = Array("PRECID", "PACCT", "PEXCH", "PFC", "PSUBTY", "PSTRIK", "PCTYM", "PSBCUS", "PBS", "PQTY", "PPRTCP")
For Each ws In ActiveWorkbook.Sheets
Select Case ws.Name
'any worksheet names listed here won't have their headers updated
Case "NoUpdate", "Leave Alone"
'Do nothing
'Update headers for all other sheets
Case Else
ws.Range("A1").Resize(, UBound(aHeaders) - LBound(aHeaders) + 1).Value = aHeaders
End Select
Next ws
End Sub
I have written a macro, which should read the value in every sheet (Row and Column) based on the value given it should Lock the cell or leave it unlocked. The way the code is written right now it takes forever to compute. I was suggested it be done using arrays. However the array are also not working
My excel file has got 15 sheets.
My Code is below.
Private Sub Workbook_Open()
Dim sh As Object
Dim sheetnames As String
Dim i As Integer
Dim col As Range
Dim rng As Variant: Set rng = Application.Range("I16:BI300") 'Value Lock & Unlock is in Column Range I16 to BI16 and Row Range B16 to B300
Dim rngCell As Variant
Application.ScreenUpdating = False
For Each sh In Sheets 'First Each
If sh.Name <> "Configuration" Then 'Configuration If
sheetnames = sh.Name
Worksheets(sheetnames).Activate
ActiveSheet.Unprotect Password:="sos"
For Each rngCell In Range("I22:BI300")
If (Cells(1, rngCell.Column) = "Lock" And Cells(rngCell.Row, 1) = "Lock") Or (Cells(1, rngCell.Column) = "UnLock" And Cells(rngCell.Row, 1) = "Lock") Or (Cells(1, rngCell.Column) = "Lock" And Cells(rngCell.Row, 1) = "Unlock") Then
rngCell.Locked = True
rngCell.Font.Color = -16776961
Else
rngCell.Locked = False
rngCell.Font.ColorIndex = xlAutomatic
End If
Next rngCell
ActiveSheet.Protect Password:="sos"
End If 'End of Configuration If
Next sh 'End of First Each
Sheets(1).Select
End Sub
Based on a combination of values in Column and Rows the result should produce values.
Column Row Value
Lock Lock Lock
Unlock Lock Lock
Lock Unlock Lock
Unlock Unlock Unlock
I'm not sure how arrays would speed this up as really it is the locking/unlocking of cells which is causing the main speed issue (Although arrays could improve the read time). Anyway, I'd suggest setting the values you wish to lock/unlock to a range and then doing them all in one go instead of individually as that will be where your main performance impact is.
Private Sub Workbook_Open()
Dim sh As Object
Dim sheetnames As String
Dim i As Integer
Dim col As Range, LockRng As Range, UnLockRng As Range
Dim rng As Variant: Set rng = Application.Range("I16:BI300") 'Value Lock & Unlock is in Column Range I16 to BI16 and Row Range B16 to B300
Dim rngCell As Variant
Application.ScreenUpdating = False
For Each sh In Sheets 'First Each
' Reset Ranges for each sheet
Set LockRng = Nothing
Set UnLockRng = Nothing
If sh.Name <> "Configuration" Then 'Configuration If
sheetnames = sh.Name
Worksheets(sheetnames).Activate
ActiveSheet.Unprotect Password:="sos"
For Each rngCell In Range("I22:BI300")
If (Cells(1, rngCell.Column) = "Lock" And Cells(rngCell.Row, 1) = "Lock") _
Or (Cells(1, rngCell.Column) = "UnLock" And Cells(rngCell.Row, 1) = "Lock") _
Or (Cells(1, rngCell.Column) = "Lock" And Cells(rngCell.Row, 1) = "Unlock") Then
' Create LockRng
If LockRng Is Nothing Then
Set LockRng = rngCell
Else
Set LockRng = Union(LockRng, rngCell)
End If
Else
' Create UnLockRng
If UnLockRng Is Nothing Then
Set UnLockRng = rngCell
Else
Set UnLockRng = Union(UnLockRng, rngCell)
End If
End If
Next rngCell
ActiveSheet.Protect Password:="sos"
End If 'End of Configuration If
' Lock all cells in LockRng
If Not LockRng Is Nothing Then
LockRng.Locked = True
LockRng.Font.Color = -16776961
End If
' Unlock all cells in UnLockRng
If Not UnLockRng Is Nothing Then
UnLockRng.Locked = False
UnLockRng.Font.ColorIndex = xlAutomatic
End If
Next sh 'End of First Each
Sheets(1).Select
End Sub
Good afternoon, I would like by means of the changed cell value macro function
in Sheet1.Range ("I15:I18") to introduce a text value based on Vlookup function, avoiding using the formula. This is the table that Vlookup function text is looking at:
A B
1 0 Low Risk
2 10 Medium Risk
3 15 High Risk
It follows the code that it doesn't work for me:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim num As Long
Dim sRes As Variant
Set KeyCells = Sheet1.Range("I15:I18")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
sRes = Application.VLookup(num, Sheet2.Range("A56:B58"), 2, True)
Debug.Print sRes
Sheet1.Target.Offset(0, 1).Text = sRes
End If
End Sub
The actual score that falls in the range is triggered by another macro that it works perfectly.
Here also follow the macro that works alright with a single cell:
Sub NumberVLookup()
Dim num As Long
num = 16
Dim sRes As Variant
sRes = Application.VLookup(num, Sheet2.Range("A56:B58"), 2, True)
Debug.Print sRes
Sheet2.Range("J15") = sRes
End Sub
I really appreciate your help in this regard.
Untested:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim sRes As Variant
on error goto haveError
Set rng = Application.Intersect(Me.Range("I15:I18"), Target)
If Not rng Is Nothing Then
If rng.cells.count = 1 then
sRes = Application.VLookup(rng.Value, _
Sheet2.Range("A56:B58"), 2, True)
'turn off events before updating the worksheet
Application.enableEvents = False
rng.Offset(0, 1).Value = IIf(IsError(sRes), "???", sRes)
Select Case rng.Offset(0, 1).Value
Case "Low Risk": rng.Offset(0, 2).Value = Date + 180
Case "Medium Risk": rng.Offset(0, 2).Value = Date + 150
Case "High Risk": rng.Offset(0, 2).Value = Date + 120
End Select
Application.enableEvents = True
End If '<< edit added missing line here
End If
Exit Sub
haveError:
Application.enableEvents = True '<< ensures events are reset
End Sub
I could use some assistance correcting the code below as what show when activated is the first image while I want to do the second image.
Also if you have other code to do the same job, please do. thanks in advance for your assistance.
Private Sub Worksheet_Activate()
Dim rng As Range, cell As Range
Dim a As Range, az As Range
Application.EnableEvents = False
Set rng = Range("A2:AE2")
Set az = Range("A3:AE6")
For Each cell In rng
For Each a In az
If cell.Value = "Fri" Then
a.Value = "Fri"
ElseIf cell.Value = "Sat" Then
a.Value = "Sat"
End If
Next a
Next cell
Application.EnableEvents = True
End Sub
Use the { and the } in the styling/headers section, above where you type, to insert formatted code next time please so that it looks like this. :)
Edited with your answer:
Private Sub Worksheet_Activate()
Dim rng As Range, cell As Range
Dim a As Range, az As Long 'set az = number of rows you want filled with fri/sat
Application.EnableEvents = False
Set rng = Range("A2:AE2")
az = 4
For Each cell In rng
If cell.Value = "fri" Then
For i = 1 To az
cell.Offset(i).Value = "fri"
Next i
ElseIf cell.Value = "sat" Then
For i = 1 To az
cell.Offset(i).Value = "sat"
Next i
End If
Next cell
Application.EnableEvents = True
End Sub
You get the result because you do it for each cell in az, but you dont wan't to do it so, you have to fill just the column of the found Fri or Sat.
Private Sub Worksheet_Activate()
Dim rng As Range, cell As Range
Application.EnableEvents = False
Set rng = Range("B2:BE2")
For Each cell In rng
If cell.value = "Fri" Then
For i as Integer = 3 To 6 Step 1
Cells(i,cell.column).Value = "Fri"
Next
End If
If cells.value = "Sat" Then
For i as Integer = 3 To 6 Step 1
Cells(i,cell.column).Value = "Sat"
Next
End If
Next cell
Application.EnableEvents = True
End Sub
It should be something like that i think
Also if you have other code to do the same job, please do.
The following will ask to build a new calendar worksheet based upon the current month every time you create a new worksheet.
ThisWorkbook code sheet:
Option Explicit
Private Sub Workbook_NewSheet(ByVal Sh As Object)
If MsgBox("Create new calendar?", vbYesNo, "AutoBuild") <> vbYes Then Exit Sub
'the following DELETES ANY WORKSHEET WITH THE SAME MONTH/YEAR NAME
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(Format(Date, "mmm yyyy")).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'create a new calendar worksheet based on the current month
With Sh
Dim c As Long
.Name = Format(Date, "mmm yyyy")
With .Cells(1, 1).Resize(6, Day(DateSerial(Year(Date), Month(Date) + 1, 0)))
.Formula = "=DATE(" & Year(Date) & ", " & Month(Date) & ", COLUMN())"
.Value = .Value
.Rows(1).NumberFormat = "d"
.Rows(2).Resize(.Rows.Count - 1, .Columns.Count).NumberFormat = "ddd"
.EntireColumn.ColumnWidth = 5 'AutoFit
.HorizontalAlignment = xlCenter
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
With .FormatConditions
.Delete
.Add Type:=xlExpression, Formula1:="=AND(ROW()>2, WEEKDAY(A2, 15)>2)"
.Add Type:=xlExpression, Formula1:="=WEEKDAY(A2, 15)<3"
.Add Type:=xlExpression, Formula1:="=AND(ROW()=2, WEEKDAY(A2, 15)>2)"
End With
.FormatConditions(1).NumberFormat = ";;;"
.FormatConditions(2).Interior.Color = 5287936
.FormatConditions(3).Interior.Color = 14281213
End With
End With
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
.Zoom = 80
End With
End With
End Sub
You will likely want to make adjustments but this may be a good framework to get started. I've taken the approach of using the actual dates and displying their day-of-the-month and day-of-the-week through cell Number Format Codes. This leaves the raw underlying date value(s) available for calculation and lookup. Similarly, the dates that appear blank are not actually blank; the custom number format that has been applied through Conditional Formatting simply shows no value at all in the cell.
I've found an answer to part of the question, but I need help to complete the code as it applies to one row only.
Private Sub Worksheet_Activate()
Dim cell As Range, rng As Range
Application.EnableEvents = False
Set rng = Range("A2:AE2")
For Each cell In rng
If Cells(2, cell.Column) = "Fri" Then
Cells(3, cell.Column) = "Fri"
ElseIf Cells(2, cell.Column) = "Sat" Then
Cells(3, cell.Column) = "Sat"
End If
Next cell
Application.EnableEvents = True
End Sub