I've got a routine that loops through all columns on all worksheets in a workbook to apply a conditional formatting rule to all of them. The rule is saved on each column fine and the rule I've used works, but the colour doesn't change after the routine is run. I can then go into the worksheet, select conditional formatting, click 'edit rule' > 'ok' > 'ok' and the formatting then updates on the worksheet, without having to change anything about the rule. What am I missing to get the rule to actually make a change to the worksheet?
For Each ws In ThisWorkbook.Worksheets
If ws.Name Like "*Management*" Then Exit Sub
lastRow = ws.UsedRange.Row + ws.UsedRange.Rows.Count - 1
lastCol = ws.UsedRange.Column + ws.UsedRange.Columns.Count - 1
ws.Cells.FormatConditions.Delete
For col = 1 To lastCol
Set rng = ws.Range(ws.Cells(2, col), ws.Cells(lastRow, col))
formulaStr = "=BITWISE_AND(2^INDEX(" & wsSchema.Name & "!$" & schemaLastCol & "$2" & _
":$" & schemaLastCol & "$" & schemaLastRow & ", MATCH(1, (" & wsSchema.Name & "!$A$2:$A$" & _
schemaLastRow & "=""" & ws.Name & """)*(" & wsSchema.Name & "!$B$2:$B$" & schemaLastRow & "=$" & _
XLCol(col) & "$1),0)), INDEX($" & XLCol(lastCol) & "$1:$" & XLCol(lastCol) & "$" & lastRow & ",ROW()))"
With rng
.FormatConditions.Add xlExpression, , formulaStr & " = 0"
With .FormatConditions(1)
.Interior.PatternColorIndex = xlAutomatic
.Interior.Color = RGB(255, 0, 0)
.Interior.TintAndShade = 0
.StopIfTrue = False
.SetFirstPriority
End With
.FormatConditions.Add xlExpression, , formulaStr & " > 0"
With .FormatConditions(2)
.Interior.PatternColorIndex = xlAutomatic
.Interior.Color = RGB(0, 255, 0)
.Interior.TintAndShade = 0
.StopIfTrue = False
.SetFirstPriority
End With
End With
Next
Next
Try ThisWorkbook.RefreshAll or Application.Calculate
Related
I have been developing various reports and forms for data we are currently pulling from a legacy system. I have created a form that dynamically creates buttons and spaces them according to how many buttons have been created. My error comes in where I attempt to add _Click() functionality for each button, as the code will be unique for each button created. I have tried everything I can come up with and everything I have been able to find online, all to no avail. Through various different attempts, I have gotten to points where I have the buttons and the code populated in the UserForm CodeModule, but the _Click() event would not trigger from there. Any help would be greatly appreciated.
Private Sub CommandButton5_Click()
Dim lastrow As Long, i As Integer, numButtons As Integer, newButton As Control, lineNum As Long
numButtons = 1
With Sheets("Production Capacity")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A4:AD" & lastrow).Interior.Color = RGB(255, 255, 255)
For i = 4 To lastrow
If i Mod 4 = 0 Then
If .Cells(i, "D").Value > .Cells(2, "G").Value Then
.Cells(i, "G").Interior.Color = RGB(255, 0, 0)
Set newButton = Me.Controls.Add("Forms.CommandButton.1", "button" & numButtons, False)
With newButton
.Width = 200
Select Case (numButtons Mod 3)
Case 0
.Left = 475
Case 1
.Left = 25
Case 2
.Left = 250
End Select
.Visible = True
.Height = 20
.Top = 60 + (Int((numButtons - 1) / 3) * 40)
.Caption = Sheets("Production Capacity").Cells(i, "A").Value & " - " & Sheets("Production Capacity").Cells(i, "B").Value & " DeptName"
.Font.Size = 10
.Font.Bold = True
End With
With ActiveWorkbook.VBProject.VBComponents("Class1").CodeModule
lineNum = .CreateEventProc("Click", "button" & numButtons) + 1 'This line is where the error occurs.
.InsertLines lineNum, _
"Dim lastrow as Long" & Chr(13) & _
"with Sheets(Sheets(""Production Capacity"").cells(1, ""A"").value)" & Chr(13) & _
".ShowAllData" & Chr(13) & _
"lastrow = .Cells(Rows.Count, ""B"").End(xlUp).Row" & Chr(13) & _
".Range(""A$6:$BQ$"" & lastrow).AutoFilter field:=30, Criteria1:=" & Chr(34) & ">=" & Chr(34) & " & " & Chr(34) & DateValue(Sheets("Production Capacity").Cells(i, "A").Value) & Chr(34) & ", Operator:=xlAnd, Criteria2:=" & Chr(34) & "<=" & Chr(34) & " & " & Chr(34) & DateValue(Sheets("Production Capacity").Cells(i, "B").Value) & Chr(34) & ", Operator:=xlAnd" & Chr(13) & _
"End With"
End With
numButtons = numButtons + 1
End If
The error is 'Run-time error '57017':
Event handler is invalid
on this line: lineNum = .CreateEventProc("Click", "button" & numButtons) + 1
Credit to #DisplayName! Thank you so much for helping me to simplify my solution and stop over-engineering it. My new Sub for the UserForm is as below:
Dim mColButtons As New Collection
Private Sub CommandButton5_Click()
Dim lastrow As Long, i As Integer, numButtons As Integer
Dim btnEvent As Class1
Dim ctl As MSForms.Control
numButtons = 1
With Sheets("Production Capacity")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A4:AD" & lastrow).Interior.Color = RGB(255, 255, 255)
For i = 4 To lastrow
If i Mod 4 = 0 Then
If .Cells(i, "D").Value > .Cells(2, "G").Value Then
.Cells(i, "G").Interior.Color = RGB(255, 0, 0)
Set ctl = Me.Controls.Add("Forms.CommandButton.1")
With ctl
.Width = 200
Select Case (numButtons Mod 3)
Case 0
.Left = 475
Case 1
.Left = 25
Case 2
.Left = 250
End Select
.Visible = True
.Height = 20
.Top = 60 + (Int((numButtons - 1) / 3) * 40)
.Caption = Sheets("Production Capacity").Cells(i, "A").Value & " - " & Sheets("Production Capacity").Cells(i, "B").Value & " DeptName"
.Font.Size = 10
.Font.Bold = True
.Name = "button" & numButtons
End With
Set btnEvent = New Class1
Set btnEvent.btn = ctl
Set btnEvent.frm = Me
mColButtons.Add btnEvent
numButtons = numButtons + 1
End If
My Class Module now looks like this, and it simplifies all of the logic into a concise Select statement. Thank you again.
Public WithEvents btn As MSForms.CommandButton
Public frm As UserForm
Private Sub btn_click()
Dim startDate As String, endDate As String, department As String, lastrow As Long
startDate = Split(btn.Caption, " ")(0)
endDate = Split(btn.Caption, " ")(2)
department = Split(btn.Caption, " ")(3)
With Sheets(Sheets("Production Capacity").Cells(1, "A").Value)
lastrow = .Cells(Rows.Count, "B").End(xlUp).Row
Select Case department
Case "Veneering"
.ShowAllData
.Range("A$6:$BQ$" & lastrow).AutoFilter field:=21, Criteria1:=">=" & DateValue(startDate), Operator:=xlAnd, Criteria2:="<=" & DateValue(endDate), Operator:=xlAnd
Case "MillMachining"
.ShowAllData
.Range("A$6:$BQ$" & lastrow).AutoFilter field:=30, Criteria1:=">=" & DateValue(startDate), Operator:=xlAnd, Criteria2:="<=" & DateValue(endDate), Operator:=xlAnd
Case "BoxLine"
.ShowAllData
.Range("A$6:$BQ$" & lastrow).AutoFilter field:=39, Criteria1:=">=" & DateValue(startDate), Operator:=xlAnd, Criteria2:="<=" & DateValue(endDate), Operator:=xlAnd
Case "Custom"
.ShowAllData
.Range("A$6:$BQ$" & lastrow).AutoFilter field:=48, Criteria1:=">=" & DateValue(startDate), Operator:=xlAnd, Criteria2:="<=" & DateValue(endDate), Operator:=xlAnd
Case "Finishing"
.ShowAllData
.Range("A$6:$BQ$" & lastrow).AutoFilter field:=57, Criteria1:=">=" & DateValue(startDate), Operator:=xlAnd, Criteria2:="<=" & DateValue(endDate), Operator:=xlAnd
End Select
End With
End Sub
This is for an Microsoft Excel VBA macro. What it is supposed to do, for every row, when "Late" is entered into column C, to highlight the cell 2 spaces to the left and Range of cells 3 spaces to the right through 43. So example is C4 contains "Late", highlight A4 and F4:AW4. Same goes for the word "Hold" just a different color.
Private Sub Highlight_Condition(ByVal Target As Range)
Dim lastRow As Long
Dim cell As Range
Dim i As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Application.EnableEvents = False
For i = lastRow To 1 Step -1
If .Range("C" & i).Value = "LATE" Then
Debug.Print "Checking Row: " & i
.Range("A" & i).Interior.ColorIndex = 39
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 39
ElseIf .Range("C" & i).Value = "HOLD" Then
.Range("A" & i).Interior.ColorIndex = 43
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 43
Else
.Range("A" & i & ":AW" & i).ClearContents
.Range("F" & i & ":AW" & i).ClearContents
End If
Next i
Application.EnableEvents = True
End With
End Sub
This should work for you...
Private Sub Highlight_Condition(ByVal Target As Range)
Dim lastRow As Long
Dim cell As Range
Dim i As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Application.EnableEvents = False
For i = lastRow To 1 Step -1
If .Range("C" & i).Value = "LATE" Then
Debug.Print "Checking Row: " & i
.Range("A" & i).Interior.ColorIndex = 39
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 39
ElseIf .Range("C" & i).Value = "HOLD" Then
.Range("A" & i).Interior.ColorIndex = 43
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 43
Else
.Range("A" & i & ":AW" & i).ClearContents
.Range("F" & i & ":AW" & i).ClearContents
End If
Next i
Application.EnableEvents = True
End With
End Sub
Tested and seems to work fine for me :)
... C4 contains "Late" ... (emphasis mine)
This seems to indicate that Late may be part of a longer string. I will code to that effect.
Conditional formatting rules are a quick method of achieving your cell highlighting and respond as soon as values in column C change without rerunning the sub procedure (unless more values are added below the lastRow).
Option Explicit
Sub Macro1()
Const TEST_COLUMN As String = "D"
Dim lastRow As Long, sSheetName As String
sSheetName = ActiveSheet.Name
With Worksheets(sSheetName)
lastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
With .Range("A4:A" & lastRow & ", F4:AW" & lastRow)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=isnumber(search(""late"", $c4))"
.FormatConditions(.FormatConditions.Count).Interior.ColorIndex = 39
.FormatConditions.Add Type:=xlExpression, Formula1:="=isnumber(search(""hold"", $c4))"
.FormatConditions(.FormatConditions.Count).Interior.ColorIndex = 43
End With
End With
End Sub
Great! I wanted to run this in the worksheet and not as a module. So i added a few extra lines and ByVal Target As Range to fire everytime a change is made in the range but it doesn't seem to work. Am i missing something?
Private Sub Highlight_Condition(ByVal Target As Range)
Dim LastRow As Long
Dim cell As Range
Dim i As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Application.EnableEvents = False
For i = LastRow To 1 Step -1
If .Range("C" & i).Value = "LATE" Then
Debug.Print "Checking Row: " & i
.Range("A" & i).Interior.ColorIndex = 39
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 39
ElseIf .Range("C" & i).Value = "HOLD" Then
.Range("A" & i).Interior.ColorIndex = 43
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 43
Else
.Range("A" & i).EntireRow.Interior.ColorIndex = xlNone
End If
Next i
Application.EnableEvents = True
End With
End Sub
I want to lock the in between row's of excel sheet depending the value of the two column's ,
I have following code with me but it's makes entire sheet protected.
the code is :
there is another problem when the loop goes to else part it throws "unable to set Locked property of the range class" the code is :
Do While xlsht.Cells(i, 1) <> vbNullString
If (CStr(xlsht.Cells(i, 54).Value) <> "" And (CStr(Format(xlsht.Cells(i, 55).Value, "dd-MMM-yyyy")) = CStr(Format(Now, "dd-MMM-yyyy")))) Then
.Cells.Locked = False
.Range("A" & i & " : " & "BH" & i).Cells.Locked = True
.Range("A" & i & " : " & "BH" & i).Interior.Color = RGB(255, 255, 0)
.Protect Password:=admin
Else
.Cells.Locked = False
.Range("A" & i & " : " & "AC" & i).Cells.Locked = True
.Range("AE" & i & " : " & "AT" & i).Cells.Locked = True
.Range("BB" & i & " : " & "BH" & i).Cells.Locked = True
.Protect Password:=admin
End If
i = i + 1
Loop
End With
you may be after something like this:
Dim i As Long
i = 1
With Worksheets("mySheetName") '<--| change "mySheetName" to your actual sheet name
Do While .Cells(i, 1) <> ""
If (.Cells(i, 54).Value = "abc" And .Cells(i, 55).Value = "def") Then Intersect(.Range("A:BH"), .Rows(i)).Locked = True
i = i + 1
Loop
.Protect Password:="admin"
End With
By default, the entire sheet is Locked (property of a Range or Cell).
And you can only Protect an ENTIRE sheet.
So you'll have to unLock the rest of the sheet first!
i = 1
With xlsht
.Unprotect Password:=admin
.Cells.Locked = False
Do While xlsht(i, 1) <> vbNullString
If .Cells(i, 54).Values = "abc" And .Cells(i, 55).Values = "def" Then
'here is checking the column depends the row is get lock or not
.Range("A" & i & ":BH" & i).Cells.Locked = True
i = i + 1
End If
Loop
.Protect Password:=admin
End With 'xlsht
Second question
i = 1
With xlsht
.Unprotect Password:=admin
.Cells.Locked = False
Do While .Cells(i, 1).Value <> vbNullString
If CStr(.Cells(i, 54).Value) <> vbNullString And CDate(.Cells(i, 55).Value) = Date Then
With .Range("A" & i & ":BH" & i)
.Cells.Locked = True
.Interior.Color = RGB(255, 255, 0)
End With '.Range("A" & i & ":BH" & i)
Else
.Range("A" & i & ":AC" & i).Cells.Locked = True
.Range("AE" & i & ":AT" & i).Cells.Locked = True
.Range("BB" & i & ":BH" & i).Cells.Locked = True
End If
i = i + 1
Loop
.Protect Password:=admin
End With 'xlsht
I am trying to open multiple excel worksheets for one workbook. I have following code but it generates error on Sheets("sheet3").select line.
I don't know why?
Set xlSheet = xlBook.Worksheets(3)
With xlSheet
.Name = "sheet3"
....
....
....
i = 6
Do While Not rsl.EOF
.Range("A" & i).Value = Nz(rsl!x, "")
.Range("B" & i).Value = Nz(rsl!y, "")
.Range("C" & i).Value = Nz(rsl!z, "")
.Range("D" & i).Value = Nz(rsl!xx, "")
.Range("E" & i).Value = Nz(rsl!yy, "")
.Range("F" & i).Value = Nz(rsl!zz, "")
.Range("G" & i).Value = Nz(rsl!xxx, "")
.Range("H" & i).Value = Nz(rsl!yyy, "")
.Range("I" & i).Value = Nz(rsl!zzz, "")
i = i + 1
rsl.MoveNext
Loop
End With
With xlSheet
Set rng = .Range("A6:I5000")
Sheets("sheet3").Select
rng.FormatConditions.Add Type:=xlExpression, Formula1:=""
rng.FormatConditions(rng.FormatConditions.Count).SetFirstPriority
With rng.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = ANy Color
End With
Set rng = .Range("A6:I5000")
Sheets("sheet3").Select
rng.FormatConditions.Add Type:=xlExpression, Formula1:=""
rng.FormatConditions(rng.FormatConditions.Count).SetFirstPriority
With rng.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = Any color
.TintAndShade = 0
End With
End With
Do I need to replace Sheets("").Select with something else? Or how do I achieve it?
Thanks,
I am exporting data from one workbook to another workbook to T13:Tlastrow
This data, from column F in my workbook where I run this macro, I want to be put into {nyckel="TEXT HERE";} in column T in the "new" workbook, starting from row 13 (T13).
I am stuck here. So would really appreciate some help/solution. Thanks!
Sub CopyData()
Dim wkbCurrent As Workbook, wkbNew As Workbook
Set wkbCurrent = ActiveWorkbook
Dim valg, c, LastCell As Range
Set valg = Selection
Dim wkbPath, wkbFileName, lastrow As String
Dim LastRowInput As Long
Dim lrow, rwCount, lastrow2, LastRowInput2 As Long
Application.ScreenUpdating = False
' If nothing is selected in column A
If Selection.Columns(1).Column = 1 Then
wkbPath = ActiveWorkbook.Path & "\"
wkbFileName = Dir(wkbPath & "CIF LISTEN.xlsm")
Set wkbNew = Workbooks.Open(wkbPath & "CIF LISTEN.xlsm")
'Application.Run ("'C:\Users\niclas.madsen\Desktop\TEST\CIF LISTEN.xlsm'!DelLastRowData")
LastRowInput = Cells(Rows.count, "A").End(xlDown).Row
For Each c In valg.Cells
lrow = wkbNew.Worksheets(1).Range("B1").Offset(wkbNew.Worksheets(1).Rows.count - 1, 0).End(xlUp).Row + 1
lastrow2 = Range("A" & Rows.count).End(xlUp).Row
lastrow3 = Range("T" & Rows.count).End(xlUp).Row
wkbCurrent.ActiveSheet.Range("E" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("A" & lrow)
wkbCurrent.ActiveSheet.Range("A" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("B" & lrow)
wkbCurrent.ActiveSheet.Range("F" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("T" & lrow)
' Standard inputs
wkbNew.Worksheets(1).Range("D13:D" & lastrow2).Value = "Ange referens och period"
wkbNew.Worksheets(1).Range("E13:E" & lastrow2).Value = "99999002"
wkbNew.Worksheets(1).Range("G13:G" & lastrow2).Value = "EA"
wkbNew.Worksheets(1).Range("H13:H" & lastrow2).Value = "2"
wkbNew.Worksheets(1).Range("M13:M" & lastrow2).Value = "SEK"
wkbNew.Worksheets(1).Range("N13:N" & lastrow2).Value = "sv_SE"
wkbNew.Worksheets(1).Range("P13:P" & lastrow2).Value = "TRUE"
wkbNew.Worksheets(1).Range("Q13:Q" & lastrow2).Value = "TRUE"
wkbNew.Worksheets(1).Range("S13:S" & lastrow2).Value = "Catalog_extensions"
'wkbNew.Worksheets(1).Range("T" & lastrow3).Value = "{Nyckelord=" & wkbNew.Worksheets(1).Range("T" & lastrow3).Value & ";}"
Next
' Trying to get this to work
LastRowInput2 = wkbNew.Worksheets(1).Range("T" & wkbNew.Sheets("Sheet1").UsedRange.Rows.count + 1).End(xlUp).Row
For i = 0 To LastRowInput2 - 13
wkbNew.Worksheets(1).Range("T" & 13 + i).Value = "{Nyckelord=" & wkbNew.Worksheets(1).Range("T" & 13 + i).Value & ";}"
Next i
' END HERE
' wkbNew.Close False
' Find the number of rows that is copied over
wkbCurrent.ActiveSheet.Activate
areaCount = Selection.Areas.count
If areaCount <= 1 Then
MsgBox "The selection contains " & Selection.Rows.count & " suppliers."
' Write it in A10 in CIF LISTEN
wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & Selection.Rows.count & " Suppliers Added"
Else
i = 1
For Each A In Selection.Areas
'MsgBox "Area " & I & " of the selection contains " & _
a.Rows.count & " rows."
i = i + 1
rwCount = rwCount + A.Rows.count
Next A
MsgBox "The selection contains " & rwCount & " suppliers."
' Write it in A10 in CIF LISTEN
wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & rwCount & " Suppliers Added"
End If
wkbNew.Worksheets(1).Activate
Application.ScreenUpdating = True
Else
MsgBox "Please select cell(s) in column A", vbCritical, "Error"
Exit Sub
End If
End Sub
OK Try
wkbNew.Worksheets(1).Range("T" & lrow).Value = "{Nyckelord=" & wkbCurrent.ActiveSheet.Range("F" & c.Row).Value & "}"
Instead of your line:
wkbCurrent.ActiveSheet.Range("F" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("T" & lrow)
And remove the whole block marked 'Trying to get this to work
If the code is doing the right action but on the wrong cells, then the problem is in the start and end of the For loop. Your For Loop is going from row '13 + i' where i = 0 (so row 13), to row 13 + LastRowInput2 - 13 (so LastRowInput2). This seems right to me, so the problem must be with the value in LastRowInput2.
You need to correct this line:
LastRowInput2 = wkbNew.Worksheets(1).Range("T" & wkbNew.Sheets("Sheet1").UsedRange.Rows.count + 1).End(xlUp).Row
So that is gives you the correct last row input in your data. There are several approaches to finding the end of data depending on whether there may be blank cells in the middle and other factors. This may be one option:
LastRowInput2 = wkbNew.Worksheets(1).Range("T65000").End(xlUp).Row
Be sure to step through the code and verify that LastRowInput2 is set to the value you expect and then this should work.