I have a macro that has two parts. The first part is the upper portion that color codes based on keywords, the bottom portion highlights cells that are duplicates.
The first part has a format condition that makes it only work if the corresponding cell in column "D" is has a value of .6 or greater. I need the same thing to work for the second part.
The format condition is
FormatConditions.Add xlExpression, Formula1:="=AND(D1>0.6,ISNUMBER(SEARCH(""" & aKeyColors(i, 1) & """,G1)))"
Macro:
Sub oneSixColorCodingPluskey()
'
' oneSixColorCodingPluskey Macro
'
Dim wb As Workbook
Dim wsKey As Worksheet
Dim wsFees As Worksheet
Dim aKeyColors(1 To 29, 1 To 2) As Variant
Dim aOutput() As Variant
Dim sKeyShName As String
Dim i As Long, j As Long
Set wb = ActiveWorkbook
Set wsFees = wb.Sheets("Fees")
sKeyShName = "Color Coding Key"
On Error Resume Next
Set wsKey = wb.Sheets(sKeyShName)
On Error GoTo 0
If wsKey Is Nothing Then
Set wsKey = wb.Sheets.Add(After:=ActiveSheet)
wsKey.Name = sKeyShName
With wsKey.Range("A1:B1")
.Value = Array("Word", "Color")
.HorizontalAlignment = xlCenter
.Font.Bold = True
.Borders(xlEdgeBottom).LineStyle = xlContinuous
End With
Else
wsKey.Range("A2:B" & wsKey.Rows.Count).Clear
End If
aKeyColors(1, 1) = "Strategize": aKeyColors(1, 2) = 10053120
aKeyColors(2, 1) = "Coordinate": aKeyColors(2, 2) = 10053120
aKeyColors(3, 1) = "Develop": aKeyColors(3, 2) = 10053120
aKeyColors(4, 1) = "Draft": aKeyColors(4, 2) = 10053120
aKeyColors(5, 1) = "Organize": aKeyColors(5, 2) = 10053120
aKeyColors(6, 1) = "Finalize": aKeyColors(6, 2) = 10053120
aKeyColors(7, 1) = "Maintain": aKeyColors(7, 2) = 10053120
aKeyColors(8, 1) = "Prepare": aKeyColors(8, 2) = 10053120
aKeyColors(9, 1) = "Rework": aKeyColors(9, 2) = 10053120
aKeyColors(10, 1) = "Revise": aKeyColors(10, 2) = 10053120
aKeyColors(11, 1) = "Review": aKeyColors(11, 2) = 10053120
aKeyColors(11, 1) = "Analysis": aKeyColors(11, 2) = 10053120
aKeyColors(11, 1) = "Analyze": aKeyColors(11, 2) = 10053120
aKeyColors(12, 1) = "Follow Up": aKeyColors(12, 2) = 10053120
aKeyColors(12, 1) = "Follow-Up": aKeyColors(12, 2) = 10053120
aKeyColors(13, 1) = "Maintain": aKeyColors(13, 2) = 10053120
aKeyColors(14, 1) = "Address": aKeyColors(14, 2) = 10053120
aKeyColors(15, 1) = "Attend": aKeyColors(15, 2) = 10092441
aKeyColors(16, 1) = "Confer": aKeyColors(16, 2) = 10092441
aKeyColors(17, 1) = "Meet": aKeyColors(17, 2) = 16751103
aKeyColors(18, 1) = "Work With": aKeyColors(18, 2) = 16751103
aKeyColors(19, 1) = "Correspond": aKeyColors(19, 2) = 16750950
aKeyColors(20, 1) = "Email": aKeyColors(20, 2) = 16750950
aKeyColors(20, 1) = "E-mail": aKeyColors(20, 2) = 16750950
aKeyColors(21, 1) = "Phone": aKeyColors(21, 2) = 6697881
aKeyColors(22, 1) = "Telephone": aKeyColors(22, 2) = 6697881
aKeyColors(23, 1) = "Call": aKeyColors(23, 2) = 6697881
aKeyColors(24, 1) = "Committee": aKeyColors(24, 2) = 3394611
aKeyColors(25, 1) = "Various": aKeyColors(25, 2) = 32768
aKeyColors(26, 1) = "Team": aKeyColors(26, 2) = 13056
aKeyColors(27, 1) = "Print": aKeyColors(27, 2) = 10092543
aKeyColors(28, 1) = "Wip": aKeyColors(28, 2) = 65535
aKeyColors(29, 1) = "Circulate": aKeyColors(29, 2) = 39372
wsFees.Cells.FormatConditions.Delete
ReDim aOutput(1 To UBound(aKeyColors, 1), 1 To 2)
With wsFees.Columns("G")
For i = LBound(aKeyColors, 1) To UBound(aKeyColors, 1)
If WorksheetFunction.CountIf(.Cells, "*" & aKeyColors(i, 1) & "*") > 0 Then
j = j + 1
aOutput(j, 1) = aKeyColors(i, 1)
aOutput(j, 2) = aKeyColors(i, 2)
.FormatConditions.Add xlExpression, Formula1:="=AND(D1>0.6,ISNUMBER(SEARCH(""" & aKeyColors(i, 1) & """,G1)))"
.FormatConditions(.FormatConditions.Count).Interior.Color = aKeyColors(i, 2)
End If
Next i
End With
If j > 0 Then
wsKey.Range("A2").Resize(j, 1).Value = aOutput
For i = 1 To j
wsKey.Cells(i + 1, "B").Interior.Color = aOutput(i, 2)
Next i
wsKey.Columns("A").EntireColumn.AutoFit
End If
With wsFees.Columns("G")
.FormatConditions.AddUniqueValues
.FormatConditions(.FormatConditions.Count).SetFirstPriority
.FormatConditions(1).DupeUnique = xlDuplicate
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 192
.TintAndShade = 0
End With
.FormatConditions(1).StopIfTrue = False
End With
End Sub
A formula-based CF using COUNTIFS() would likely do the job.
E.g.
Related
I am creating an useform to create, modify, search and delete data.
when I'm running the code to create data, it shows the error:
Run-time error '-2147417848(80010108)':
Method'_Default' of object 'range'failed.
I have tried to change the object (name of te worksheet.) for (activesheet.) activating the sheet where I am registering the data I want to add but still not working.
The code has several procedures, but I'm having trouble just when I am creating new data
At the beginning it worked well but now it has this issue. I am new programming.
The code fails in this area
S
et oCelda = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1)
oCelda = consecutivo
complete code as follow
Private Sub Cmb_Registro_Click()
Dim oCelda As Range
Dim bCheck As Boolean
Dim Consecutivo as Double, file As long, Col As long, Final As Long
Worksheets("Data").Activate
bCheck = Txt_Fecha <> "" And Cbo_Categoria <> "" And Cbo_Subcategoria <> "" And Txt_Monto <> "" _
And Cbo_Periodo <> "" And Txt_Descripcion <> ""
Col = 1
fila = 2
Cbo_Periodo.Enabled = False
Do While ActiveSheet.Cells(fila, Col) <> Empty
fila = fila + 1
Loop
Final = fila
Consecutivo = Val(ActiveSheet.Cells(Final - 1, Col))
If Consecutivo = 0 Then
consecutivo = 1
Else
consecutivo = ActiveSheet.Cells(Final - 1, Col) + 1
End If
If bCheck And optIngreso Then
*Set oCelda = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1)
oCelda = consecutivo*
oCelda.Offset(0, 1) = CDate(Txt_Fecha)
oCelda.Offset(0, 2) = CLng(Txt_Monto)
oCelda.Offset(0, 3) = lblIngreso.Caption
oCelda.Offset(0, 4) = Txt_Descripcion
oCelda.Offset(0, 5) = Cbo_Categoria
oCelda.Offset(0, 6) = Cbo_Subcategoria
oCelda.Offset(0, 7) = Cbo_Periodo
MsgBox "Registro completo"
Unload Me
ElseIf bCheck And optEgreso Then
*Set oCelda = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1)
oCelda = consecutivo*
oCelda.Offset(0, 1) = CDate(Txt_Fecha)
oCelda.Offset(0, 2) = CLng(Txt_Monto)
oCelda.Offset(0, 3) = lblEgreso.Caption
oCelda.Offset(0, 4) = Txt_Descripcion
oCelda.Offset(0, 5) = Cbo_Categoria
oCelda.Offset(0, 6) = Cbo_Subcategoria
oCelda.Offset(0, 7) = Cbo_Periodo
MsgBox "Registro completo"
Unload Me
Else
MsgBox "Faltan datos"
End If
Worksheets("Inicio").Activate
End Sub
I have an excel sheet name as Terminal Volumes In this sheet, there are three variables (Terminal LF (log Fisher Cost) and CT Cost) that are using as input. I am using the following code for working on these.
enter code here
Sub InitiateValues()
ReDim TrmPnts(11) '<<<<CHANGE HERE Total Point + SE -JJ
Set ShDat = Worksheets("Data")
Set ShDatPth = Worksheets("DataPath")
Set tvol = Worksheets("Terminal Volumes")
'ShDatPth.Range("B2:FB157").Value = 0
With TrmPnts(1)
.Cpt = "T1"
.CptColr = "&H000088"
.Row = ShDat.Cells(2, 1)
.Col = ShDat.Cells(3, 1)
.LFamt = tvol.Cells(2, 2)
.CTamt = tvol.Cells(2, 3)
End With
With TrmPnts(3)
.Cpt = "T2"
.CptColr = "&H000088"
.Row = ShDat.Cells(6, 1)
.Col = ShDat.Cells(7, 1)
.LFamt = tvol.Cells(3, 2)
.CTamt = tvol.Cells(3, 3)
End With
With TrmPnts(4)
.Cpt = "T3"
.CptColr = "&H000088"
.Row = ShDat.Cells(8, 1)
.Col = ShDat.Cells(9, 1)
.LFamt = tvol.Cells(4, 2)
.CTamt = tvol.Cells(4, 3)
End With
With TrmPnts(5)
.Cpt = "T4"
.CptColr = "&H000088"
.Row = ShDat.Cells(10, 1)
.Col = ShDat.Cells(11, 1)
.LFamt = tvol.Cells(5, 2)
.CTamt = tvol.Cells(5, 3)
End With
With TrmPnts(6)
.Cpt = "T5"
.CptColr = "&H000088"
.Row = ShDat.Cells(12, 1)
.Col = ShDat.Cells(13, 1)
.LFamt = tvol.Cells(6, 2)
.CTamt = tvol.Cells(6, 3)
End With
With TrmPnts(7)
.Cpt = "T6"
.CptColr = "&H000088"
.Row = ShDat.Cells(14, 1)
.Col = ShDat.Cells(15, 1)
.LFamt = tvol.Cells(7, 2)
.CTamt = tvol.Cells(7, 3)
End With
With TrmPnts(8)
.Cpt = "T7"
.CptColr = "&H000088"
.Row = ShDat.Cells(16, 1)
.Col = ShDat.Cells(17, 1)
.LFamt = tvol.Cells(8, 2)
.CTamt = tvol.Cells(8, 3)
End With
With TrmPnts(9)
.Cpt = "T8"
.CptColr = "&H000088"
.Row = ShDat.Cells(18, 1)
.Col = ShDat.Cells(19, 1)
.LFamt = tvol.Cells(9, 2)
.CTamt = tvol.Cells(9, 3)
End With
With TrmPnts(10)
.Cpt = "T9"
.CptColr = "&H000088"
.Row = ShDat.Cells(20, 1)
.Col = ShDat.Cells(21, 1)
.LFamt = tvol.Cells(10, 2)
.CTamt = tvol.Cells(10, 3)
End With
With TrmPnts(11)
.Cpt = "T10"
.CptColr = "&H000088"
.Row = ShDat.Cells(22, 1)
.Col = ShDat.Cells(23, 1)
.LFamt = tvol.Cells(11, 2)
.CTamt = tvol.Cells(11, 3)
End With '<<<<<<CHANGE HERE
With TrmPnts(2)
.Cpt = "SE"
.CptColr = "&H004400"
.Row = ShDat.Cells(4, 1)
.Col = ShDat.Cells(5, 1)
End With
ReDim Mtx(156, 157) ' Cell Size X,Y -JJ
For i = 1 To 156 ' Cell Size X,Y -JJ 1 To 226
For j = 1 To 157 ' Cell Size X,Y -JJ
Mtx(i, j) = ShDat.Cells(1 + i, 1 + j)
ShDatPth.Cells(1 + i, 1 + j) = 0
Next
Next
EdtMod = True
End Sub
This code working fine to input the value to T10 (Only for 10 Rows). I want to use it for T1500 (1500 Rows) for the Column A to Column C- using loop.
The structure of the worksheet is as under.
Just make a For...next loop and use the variable of the loop to calculate the correct fields like the following (I hope I interpreted the logic correctly, please check):
Sub InitiateValues()
ReDim trmpnts(11) '<<<<CHANGE HERE Total Point + SE -JJ
Set ShDat = Worksheets("Data")
Set ShDatPth = Worksheets("DataPath")
Set tvol = Worksheets("Terminal Volumes")
'ShDatPth.Range("B2:FB157").Value = 0
Dim I As Long
For I = 1 To UBound(trmpnts)
With trmpnts(I)
.Cpt = "T" & I
.CptColr = "&H000088"
.Row = ShDat.Cells(I * 2, 1)
.Col = ShDat.Cells(I * 2 + 1, 1)
.LFamt = tvol.Cells(I, 2)
.CTamt = tvol.Cells(I, 3)
End With
Next I
....
End Sub
That should do the trick...
I am having an issue with the "Subscript out of Range" error message. I got some help writing a code that loops a long list of stocks. The code basically makes all of the vectors even so i can use it in a panel data setting.
The loop stops after 4 stocks and gives me a "Subscript out of Range" error.
I can run the code over the first 95 "i" i.e. if i transform the first part:
For i = 4 To 95
If Cells(i, 1) <> Cells(i - 1, 1) Then Clean_Stock_2 (i)
Code:
**Sub Outer_Loop()
For i = 4 To Cells(Rows.Count, 1).End(xlUp).Row**
If Cells(i, 1) <> Cells(i - 1, 1) Then Clean_Stock_2 (i)
Next i
End Sub
Sub Clean_Stock_2(ByVal r As Long)
Dim Stock(31, 5)
Dim Quarter(31)
Dim Bo As Boolean
Charge = 0
'Frame
For i = 0 To 31
Stock(i, 0) = Cells(r, 1)
Stock(i, 1) = Cells(r, 2)
Stock(i, 2) = Cells(r, 3)
Stock(i, 5) = "Q" & Format(DateAdd("q", i, #1/1/2011#), "q-YYYY")
Quarter(i) = Stock(i, 5)
Next i
'Data
Do While Cells(r, 1) = Stock(0, 0)
Qu = "Q" & Format(Cells(r, 4), "q-YYYY")
rr = Application.Match(Qu, Quarter, 0)
If Not IsError(rr) Then
Stock(rr, 3) = Cells(r, 4)
Stock(rr, 4) = Cells(r, 5)
If Not Bo Then Charge = Stock(rr, 4): Bo = True
End If
r = r + 1
Loop
'fill
For i = 0 To 31
If Stock(i, 4) = 0 Then
Stock(i, 4) = Charge
Else
Charge = Stock(i, 4)
End If
Next i
'Output
lr = Cells(Rows.Count, "I").End(xlUp).Row + 1
lr = IIf(lr < 3, 3, lr)
Cells(lr, "I").Resize(32, 6) = Stock
End Sub
I currently have a macro that will apply conditional formatting to a cell (in this it is cell "G" but I think it would be better if I was able to have the macro apply the conditional formatting to whatever cell I have selected so that I am not limited to only the cell I have setup in the macro.
Sub ColorCoringPluskey()
'
' ColorCoringPluskey Macro
'
Dim wb As Workbook
Dim wsKey As Worksheet
Dim wsFees As Worksheet
Dim aKeyColors(1 To 20, 1 To 2) As Variant
Dim aOutput() As Variant
Dim sKeyShName As String
Dim i As Long, j As Long
Set wb = ActiveWorkbook
Set wsFees = wb.Sheets("Fees")
sKeyShName = "Color Coding Key"
On Error Resume Next
Set wsKey = wb.Sheets(sKeyShName)
On Error GoTo 0
If wsKey Is Nothing Then
Set wsKey = wb.Sheets.Add(After:=ActiveSheet)
wsKey.Name = sKeyShName
With wsKey.Range("A1:B1")
.Value = Array("Word", "Color")
.HorizontalAlignment = xlCenter
.Font.Bold = True
.Borders(xlEdgeBottom).LineStyle = xlContinuous
End With
Else
wsKey.Range("A2:B" & wsKey.Rows.Count).Clear
End If
aKeyColors(1, 1) = "Strategize": aKeyColors(1, 2) = 10053120
aKeyColors(2, 1) = "Coordinate": aKeyColors(2, 2) = 13421619
aKeyColors(3, 1) = "Committee": aKeyColors(3, 2) = 16777062
aKeyColors(4, 1) = "Attention": aKeyColors(4, 2) = 2162853
aKeyColors(5, 1) = "Work": aKeyColors(5, 2) = 5263615
aKeyColors(6, 1) = "Circulate": aKeyColors(6, 2) = 10066431
aKeyColors(7, 1) = "Numerous": aKeyColors(7, 2) = 13158
aKeyColors(8, 1) = "Follow up": aKeyColors(8, 2) = 39372
aKeyColors(9, 1) = "Attend": aKeyColors(9, 2) = 65535
aKeyColors(10, 1) = "Attention to": aKeyColors(10, 2) = 65535
aKeyColors(11, 1) = "Print": aKeyColors(11, 2) = 10092543
aKeyColors(12, 1) = "WIP": aKeyColors(12, 2) = 13056
aKeyColors(13, 1) = "Prepare": aKeyColors(13, 2) = 32768
aKeyColors(14, 1) = "Develop": aKeyColors(14, 2) = 3394611
aKeyColors(15, 1) = "Participate": aKeyColors(15, 2) = 10092441
aKeyColors(16, 1) = "Organize": aKeyColors(16, 2) = 13369548
aKeyColors(17, 1) = "Various": aKeyColors(17, 2) = 16751103
aKeyColors(18, 1) = "Maintain": aKeyColors(18, 2) = 16724787
aKeyColors(19, 1) = "Team": aKeyColors(19, 2) = 16750950
aKeyColors(20, 1) = "Address": aKeyColors(20, 2) = 6697881
wsFees.Cells.FormatConditions.Delete
ReDim aOutput(1 To UBound(aKeyColors, 1), 1 To 2)
With wsFees.Columns("G")
For i = LBound(aKeyColors, 1) To UBound(aKeyColors, 1)
If WorksheetFunction.CountIf(.Cells, "*" & aKeyColors(i, 1) & "*") > 0 Then
j = j + 1
aOutput(j, 1) = aKeyColors(i, 1)
aOutput(j, 2) = aKeyColors(i, 2)
.FormatConditions.Add xlTextString, String:=aKeyColors(i, 1), TextOperator:=xlContains
.FormatConditions(.FormatConditions.Count).Interior.Color = aKeyColors(i, 2)
End If
Next i
End With
If j > 0 Then
wsKey.Range("A2").Resize(j, 1).Value = aOutput
For i = 1 To j
wsKey.Cells(i + 1, "B").Interior.Color = aOutput(i, 2)
Next i
wsKey.Columns("A").EntireColumn.AutoFit
End If
End Sub
Thanks for any help!
enter image description here[enter image description here][2]Hi,
I have an issue and hopefully someone can help. I have an Excel sheet and I Need to check if starting from last row if the same value as in column 4 from last row exists somewhere above, but condition is, that only if column 1 and column 2 are same and not in column 3 is the word "SK" or "SV" and then I Need to sum the values in column 7 and concaternate column 3 and column 6 and just Keep one line and the other which were the base of this calculation must be deleted.
Attached you will find the screenshots. First how the Excel file Looks like before processing and next screenshot how it should look like afterwards.
enter image description here
Here is the code:
Sub combine_data()
Dim vLastRow As Integer
Dim Col_A_Str As String
Dim Col_B_Str As String
Dim r As Integer
Dim vDatarow As Integer
Dim vCodeStr3 As String
Dim vCodeStr6 As String
Dim vTotal As Double
Dim Col_D_Str As String
vLastRow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
Col_A_Str = ""
Col_B_Str = ""
r = 1
vDatarow = 0
vCodeStr3 = ""
vCodeStr6 = ""
vTotal = 0
Col_D_Str = ""
Col_A_Str = Trim(Cells(vLastRow, 1))
Col_B_Str = Trim(Cells(vLastRow, 2))
Col_D_Str = Trim(Cells(vLastRow, 4))
Do Until r = vLastRow
DoEvents
If Trim(Cells(r, 4)) = Col_D_Str Then
If Trim(Cells(r, 1)) = Col_A_Str Then
If Trim(Cells(r, 2)) = Col_B_Str Then
If UCase(Trim(Cells(r, 3))) <> "SV" And UCase(Trim(Cells(r, 3))) <> "SK" Then
If vDatarow = 0 Then
If vDatarow = 0 Then vDatarow = r
vCodeStr3 = Trim(Cells(r, 3))
vCodeStr6 = Trim(Cells(r, 6))
vTotal = Cells(r, 7)
r = r + 1
Else
vCodeStr3 = vCodeStr3 & ", " & Trim(Cells(r, 3))
vCodeStr6 = vCodeStr6 & ", " & Trim(Cells(r, 6))
vTotal = vTotal + Cells(r, 7)
Cells(r, 1).EntireRow.Delete
vLastRow = vLastRow - 1
End If
Else
r = r + 1
End If
Else
r = r + 1
End If
Else
r = r + 1
End If
Else
r = r + 1
End If
Loop
Cells(vDatarow, 3).ClearContents
Cells(vDatarow, 3) = vCodeStr3
Cells(vDatarow, 6).ClearContents
Cells(vDatarow, 6) = vCodeStr6
Cells(vDatarow, 7).ClearContents
Cells(vDatarow, 7) = vTotal
End Sub