I have this worksheet and i need to compare the "venda" values with "esperado".
If Vendas > Esperado i need to paint the status cell with green, if Vendas < Esperado it will be red
Is there a way to make this process entirely on vba? I am still learning this tool
Please, use the next code. It will create two Union ranges (for each cell interior color type), according to the required condition and color their interior at the code end, at once. That's why it will be fast enough for reasonable ranges number of rows. If huge ranges, I can supply a different solution:
Sub PaintCells()
Dim sh As Worksheet, lastR As Long, arr, rngGreen As Range, rngRed As Range, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
arr = sh.Range("B2:C" & lastR).Value2
For i = 1 To UBound(arr)
If arr(i, 1) > arr(i, 2) Then
addURange rngGreen, sh.Range("D" & i + 1)
ElseIf arr(i, 1) < arr(i, 2) Then
addURange rngRed, sh.Range("D" & i + 1)
End If
Next i
If Not rngGreen Is Nothing Then rngGreen.Interior.Color = vbGreen
If Not rngRed Is Nothing Then rngRed.Interior.Color = vbRed
End Sub
Sub addURange(rngU As Range, rngAdd As Range)
If rngU Is Nothing Then
Set rngU = rngAdd
Else
Set rngU = Application.Union(rngU, rngAdd)
End If
End Sub
Sub ValiaFuncionario()
Dim tables As Range
Set table = Range("B8", Range("B8").End(xlToRight).End(xlDown))
For Each Row In table.Rows
If Row.Cells(1, 2).Value < Row.Cells(1, 3) Then
Row.Cells(1, 4).Interior.Color = vbRed
Row.Cells(1, 4).Value = "ABAIXO"
Else
Row.Cells(1, 4).Interior.Color = vbGreen
Row.Cells(1, 4).Value = "ACIMA"
End If
Next Row
End Sub
i did like this and it worked
Related
I am trying to get a faster and more efficient code than this one, as range will increase a lot over time, so I will need to substitute For Each.
The macro would look up the value "Monday" through each cell of a column and, if found, it would return the value "Substract" in the preceding cell in column A.
Sub ForEachTest()
Dim Rng As Range
Set Rng = Range("B3:B1000")
For Each cell In Rng
If cell.Value = "Monday" Then
cell.Offset(0, -1) = "Substract"
End If
Next cell
End Sub
Loop within VBA rather than on the worksheet:
Sub faster()
Dim arr()
arr = Range("A3:B1000")
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, 2) = "Monday" Then arr(i, 1) = "Substract"
Next i
Range("A3:B1000") = arr
End Sub
EDIT#1:
This version addresses BigBen's concern that column B should not be overwritten so as to preserve any formulas in that column. Only column A is overwritten here:
Sub faster2()
Dim arr(), brr()
arr = Range("A3:A1000")
brr = Range("B3:B1000")
For i = LBound(brr, 1) To UBound(brr, 1)
If brr(i, 1) = "Monday" Then arr(i, 1) = "Substract"
Next i
Range("A3:A1000") = arr
End Sub
You can avoid the loop by filtering your data and working with the resulting visible set of data.
This will only modify the cells in Column A when Column B = Monday. All other cells remain as-is
Sub Shelter_In_Place()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
lr As Long
lr = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
ws.Range("A1:B" & lr).AutoFilter Field:=2, Criteria1:="Monday"
ws.Range("A2:A" & lr).SpecialCells(xlCellTypeVisible).Value = "Subtract"
ws.AutoFilterMode = False
End Sub
Try using Evaluate
Sub Test()
With Range("A3:A" & Cells(Rows.Count, 2).End(xlUp).Row)
.Value = Evaluate("IF(" & .Offset(, 1).Address & "=""Monday"",""Substract"","""")")
End With
End Sub
Thank you in advance for your help.
I am trying to build a macro (which in the end will be part of a bigger macro) that will compare two IDs and based on findings will perform another operation.
The code that I have at the moment only copies the values for each row without any consideration of ID in the first column. Here is the code:
Sub movingValues()
'declaring/setting variables
Dim SheetOneWs As Worksheet, SheetTwoWs As Worksheet
Dim SheetOneLastRow As Long, SheetTwoLastRow As Long
Dim SheetOneRng As Range, SheetTwoRng As Range
Dim cell As Range, i As Integer
Application.Calculation = xlCalculationManual
Set SheetOneWs = ThisWorkbook.Worksheets("SheetOne")
Set SheetTwoWs = ThisWorkbook.Worksheets("SheetTwo")
SheetOneLastRow = SheetOneWs.Range("A" & Rows.Count).End(xlUp).Row
SheetTwoLastRow = SheetTwoWs.Range("A" & Rows.Count).End(xlUp).Row
Set SheetOneRng = SheetOneWs.Range("A2:D13" & SheetOneLastRow)
Set SheetTwoRng = SheetTwoWs.Range("A2:M13" & SheetTwoLastRow)
SheetOneWs.Range("B2:D13").Value = ""
For i = 2 To SheetTwoLastRow
'For Each cell In SheetTwoWs.Range(Cells(i, "B"), Cells(i, "M"))
For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
If cell.Value = "No" Then
SheetOneWs.Cells(cell.Row, "B").Value = SheetTwoWs.Cells(1, cell.Column)
Exit For
End If
SheetOneWs.Cells(cell.Row, "B").Value = "No data"
Next cell
For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
If cell.Value = "Maybe" Then
SheetOneWs.Cells(cell.Row, "C").Value = SheetTwoWs.Cells(1, cell.Column)
Exit For
End If
SheetOneWs.Cells(cell.Row, "C").Value = "No data"
Next cell
For Each cell In SheetTwoWs.Range("B" & i & ":" & "M" & i)
If cell.Value = "Yes" Then
SheetOneWs.Cells(cell.Row, "D").Value = SheetTwoWs.Cells(1, cell.Column)
Exit For
End If
SheetOneWs.Cells(cell.Row, "D").Value = "No data"
Next cell
Next i
Application.Calculation = xlCalculationManual
End Sub
My understanding is that I need to place that inside of another loop to match the IDs, so far I've tried:
For i = 2 To SheetOneLastRow
For a = 2 To SheetTwoLastRow
valTwo = Worksheets("SheetTwo").Range("A" & a).Value
If Cells(i, 1) = valTwo Then
'CODE FROM ABOVE'
End if
Next a
Next i
doesn't seem to work the way I intend it too, all your help will be greatly appreciated. The code initially was taken from the answer in here: Issue with copying values based on condition from one sheet to another VBA
Thank you once again for all your answers.
Best Regards,
Sergej
As far as I can tell, this does what you want.
Sub x()
Dim rID As Range, rMonth As Range, rData As Range, rCell As Range, v As Variant
With Worksheets("SheetTwo")
Set rID = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
Set rMonth = .Range("B1:M1")
Set rData = .Range("B2").Resize(rID.Rows.Count, rMonth.Columns.Count)
End With
With Worksheets("SheetOne")
For Each rCell In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
v = Application.Match(rCell.Value, rID, 0)
If IsNumeric(v) Then
rCell.Offset(, 1).Value = rMonth.Cells(Application.Match("No", rData.Rows(v), 0))
rCell.Offset(, 2).Value = rMonth.Cells(Application.Match("Maybe", rData.Rows(v), 0))
rCell.Offset(, 3).Value = rMonth.Cells(Application.Match("Yes", rData.Rows(v), 0))
End If
Next rCell
End With
End Sub
Because I couldn't really bear looking at your horribly inefficient code, I've reworked it here based on the data provided in your previous question.
What this does is it loops over sheet 2 column A. Then for every cell it finds the corresponding ID and stores the row in "Hit".
It then finds three values in the row of the cell, and adds the month linked to every hit to the correct place in an array.
Then it pastes the array in one go to the correct range in sheet 1.
Sub movingValues()
Dim SheetOneWs As Worksheet, SheetTwoWs As Worksheet
Dim SheetOneLastRow As Long, SheetTwoLastRow As Long
Dim cel As Range, hit As Range
Dim Foundrow As Integer
Dim arr() As Variant
Application.Calculation = xlCalculationManual
Set SheetOneWs = ThisWorkbook.Worksheets("Sheet1")
Set SheetTwoWs = ThisWorkbook.Worksheets("Sheet2")
SheetOneLastRow = SheetOneWs.Range("A" & Rows.Count).End(xlUp).Row
SheetTwoLastRow = SheetTwoWs.Range("A" & Rows.Count).End(xlUp).Row
ReDim arr(1 To SheetOneLastRow - 1, 1 To 3)
For Each cel In SheetTwoWs.Range("A2:A" & SheetTwoLastRow)
Foundrow = SheetOneWs.Range("A1:A" & SheetOneLastRow).Find(cel.Value).Row - 1
If Not Foundrow = 0 Then
Set hit = SheetTwoWs.Rows(cel.Row).Find("No", SearchDirection:=xlNext)
If Not hit Is Nothing Then
arr(Foundrow, 1) = SheetTwoWs.Cells(1, hit.Column).Value
Else
arr(Foundrow, 1) = "No Data"
End If
Set hit = SheetTwoWs.Rows(cel.Row).Find("Maybe", SearchDirection:=xlNext)
If Not hit Is Nothing Then
arr(Foundrow, 2) = SheetTwoWs.Cells(1, hit.Column).Value
Else
arr(Foundrow, 2) = "No Data"
End If
Set hit = SheetTwoWs.Rows(cel.Row).Find("Yes", SearchDirection:=xlNext)
If Not hit Is Nothing Then
arr(Foundrow, 3) = SheetTwoWs.Cells(1, hit.Column).Value
Else
arr(Foundrow, 3) = "No Data"
End If
End If
Next cel
SheetOneWs.Range("B2:D" & SheetOneLastRow) = arr
End Sub
As you can probably see when trying it, reading your values into an array first makes this pretty much instant, since it saves on "expensive" write actions. With the tests in place and this structure it should be much more straightforward and rigid than your previous code. Using Find means it only needs to loop over each row once, further increasing performance.
Please note, it's best to back up your data before trying in case of unexpected results and/or errors.
How can I compare cells in two rows and and match the lower cell value to the upper cell value, if the two are different? Here is some the same data I am working with and what I hope to see after the code runs.
Before:
[ID_GLOBAL], [ID_UNIQUE], [ID_REAL], [ID_1], [ID_2], [GAS_ADJ], [OBJ_ADJ]
[ID_GLOBAL], [ID_UNIQUE], [ID_REAL], [GAS_ADJ], [OBJ_ADJ]
After:
[ID_GLOBAL], [ID_UNIQUE], [ID_REAL], [ID_1], [ID_2], [GAS_ADJ], [OBJ_ADJ]
[ID_GLOBAL], [ID_UNIQUE], [ID_REAL], NULL AS [ID_1], NULL AS [ID_2], [GAS_ADJ], [OBJ_ADJ]
I think the code will basically look like this, but I haven't gotten the insert-right working properly.
Sub CompareCellsDiffRows()
Dim bothrows As Range, i As Integer
Set bothrows = Selection
With bothrows
For i = 1 To .Columns.Count
If Not StrComp(.Cells(1, i), .Cells(2, i), vbBinaryCompare) = 0 Then
' magic happens here
End If
Next i
End With
End Sub
As you may have guessed, I'm dealing with hundreds of fields in several tables and trying to Union everything together, so all these field names have to match up in the correct order.
Thanks.
I am assuming, as per your example, that the first row is the one that will be always complete.
Sub CompareRowDifferences()
Dim sht As Worksheet
Dim i, LastColumn As Long
Set sht = ThisWorkbook.Worksheets("Transposed Fields")
LastColumn = sht.Cells.SpecialCells(xlLastCell).Column
With sht
For i = 1 To LastColumn
If StrComp(.Cells(1, i), .Cells(2, i), vbBinaryCompare) <> 0 Then
.Cells(2, i).Insert Shift:=xlToRight
.Cells(2, i).Value2 = "NULL AS " & .Cells(1, i).Value2
End If
Next i
End With
End Sub
Hope it helps
Regarding your second question (if they are not ordered) and assuming always that the first line is the ones that rules...
Sub CompareRowDifferences()
Dim sht As Worksheet
Dim i, j, LastColumn As Long
Set sht = ThisWorkbook.Worksheets("Transposed Fields")
LastColumn = sht.Cells.SpecialCells(xlLastCell).Column
j = 0
With sht
For i = 1 To LastColumn
Test = Application.WorksheetFunction.CountIf(Range _
(Cells(2, i), Cells(2, LastColumn + j)), .Cells(1, i).Value2)
If Test >= 1 Then
.Cells(2, i).Insert Shift:=xlToRight
.Cells(2, i).Value2 = .Cells(1, i).Value2
Else
.Cells(2, i).Insert Shift:=xlToRight
.Cells(2, i).Value2 = "NULL AS " & .Cells(1, i).Value2
End If
j = j + 1
Next i
Range(Cells(2, LastColumn), Cells(2, LastColumn + j)).ClearContents
End With
End Sub
This procedure identifies and uses the row with a higher number of fields (i.e. no-empty cells), and uses it as "model" to update the other row regardless of the position of the fields in the other row.
Sub Headers_Comparison(rInput As Range)
Dim aOut As Variant, aSrc As Variant, aTrg As Variant
Dim bMatch As Byte, bRow As Byte, b As Byte
With WorksheetFunction
Rem Validate Fields in Rows
If .CountA(rInput.Rows(1)) > .CountA(rInput.Rows(2)) Then
bRow = 2
aSrc = .Transpose(.Transpose(rInput.Rows(1).Value2))
aTrg = .Transpose(.Transpose(rInput.Rows(2).Value2))
Else
bRow = 1
aSrc = .Transpose(.Transpose(rInput.Rows(2).Value2))
aTrg = .Transpose(.Transpose(rInput.Rows(1).Value2))
End If
aOut = aTrg
For b = 1 To UBound(aSrc)
bMatch = 0
On Error Resume Next
bMatch = .Match(aSrc(b), aTrg, 0)
On Error GoTo 0
aOut(b) = IIf(bMatch > 0, vbNullString, "NULL AS ") & aSrc(b)
Next: End With
rInput.Rows(bRow).Value = aOut
End Sub
It should be called in this manner:
Call Headers_Comparison(rSel) 'update with required range
I think I just figured it out!
Sub CompareRowDifferences()
Dim i As Integer
Dim sht As Worksheet
Dim LastColumn As Long
Set sht = ThisWorkbook.Worksheets("Transposed Fields")
LastColumn = sht.UsedRange.Columns(sht.UsedRange.Columns.Count).Column
For i = 1 To LastColumn
If Not StrComp(sht.Cells(1, i), sht.Cells(2, i), vbBinaryCompare) = 0 Then
' magic happens here
Set Rng = sht.Cells(2, i)
Rng.Insert Shift:=xlToRight
sht.Cells(2, i).Value = "NULL AS " & sht.Cells(1, i).Value
End If
Next i
End Sub
This seems to work. Although, this is a pretty simple solution. I understand it would be much more complex if the order of names the lower row changed. This works ONLY because the names in row 2 match the names in row 1, there are just fewer names. I would love to see what the code would look like if the order of the row 2 names was switch around, compared to the row 1 names.
Very new to VBA but have managed to learn a lot in the last few weeks and stitch together some code for a project at work.
I am struggling with a loop within a loop.
Essentially I want to find every column in Row 1 that has cell value of "Item Cost" then loop down through each row in that column and place a subtotal in the blanks.
Any help with a solution would be greatly appreciated. It is part of a much larger project but I am at this sticking Point.
Code:
[VBA]
Sub InsertTotals()
Dim sh As Worksheet
Dim rw As Range
Dim RowCount As Integer
RowCount = 0
Set sh = ActiveSheet
For Each rw In sh.Rows
If sh.Cells(rw.Row, 1).Value = "Item Cost" Then
Dim ThisCell As Range
Dim MySum As Double
Set ThisCell = rw.offset(-1)
nxt:
Do While ThisCell <> ""
MySum = MySum + ThisCell
Set ThisCell = ThisCell.offset(1, 0)
Loop
ThisCell.Value = MySum
If ThisCell.offset(1, 0) <> "" Then
Set ThisCell = ThisCell.offset(1, 0)
MySum = 0
GoTo nxt
End If
End If
Next rw
End Sub
[VBA]
I've changed the way that the start and stop of the ranges to be subtotaled were collected. Additionally, every row has a subtotal at the bottom since there is likely an empty cell there.
Sub Insert_SubTotals()
Dim sh As Worksheet
Dim rw As Long, srw As Long, col As Long
Set sh = ActiveSheet
With sh
For col = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
If .Cells(1, col) = "Item Cost" Then
srw = 2
For rw = 2 To .Cells(Rows.Count, col).End(xlUp).Row + 1
If IsEmpty(.Cells(rw, col)) And rw > srw Then
'.Cells(rw, col).Value = Application.Sum(.Range(.Cells(srw, col), .Cells(rw - 1, col)))
.Cells(rw, col).Formula = "=SUM(" & .Cells(srw, col).Address(0, 0) & _
Chr(58) & .Cells(rw - 1, col).Address(0, 0) & ")"
.Cells(rw, col).NumberFormat = _
"[color5]_($* #,##0.00_);[color9]_($* (#,##0.00);[color15]_("" - ""_);[color10]_(#_)"
srw = rw + 1
End If
Next rw
End If
Next col
End With
Set sh = Nothing
End Sub
I applied a blue Accounting style number format to distinguish the subtotals from the rest of the numbers. Modify that as you see fit. The subtotals remain as =SUM(...) formulas. I've added (and commented) a line that would simply leave the values just above the formula assignment.
Hi all I am using the script below to check a number of columns against column A, However it is extremely slow and I was wondering if anyone knows of a quicker method.
In here I have a range of cells on different sheets being compared, once the comparison is made a check mark is made in the adjacent column and it is copied and pasted into a final sheet (possibly another slowing process) I cant think of a way to transpose without copying and pasting?
Sub CompareAndMove()
Dim rng1 As Range, rng2 As Range, i As Long, k As Long, kL As Long, iL As Long, var As Variant, y As Workbook, lRows As Long
lRows = Sheets("COMPARE").Cells(Rows.Count, 1).End(xlUp).Row
iL = Sheets("COMPARE").Range("A" & Rows.Count).End(xlUp).Row
For j = 3 To 4
For i = 2 To iL
Set rng1 = Sheets("COMPARE").Range("A" & i)
Set rng2 = Sheets("COMPARE").Columns(j)
var = Application.Match(rng1.Value, rng2, 1)
If Not IsError(Application.Match(rng1.Value, rng2, 0)) Then bln = True
If bln = True Then
rng1.Interior.Color = RGB(255, 255, 0)
rng1.Copy
rng1.Offset(0, 1).Font.Name = "Wingdings"
rng1.Offset(0, 1).Value = ChrW(&HFC)
End If
End If
Next i
Sheets("COMPARE").Range(Cells(1, 2), Cells(lRows, "B")).Copy
Sheets("COMPAREFINAL").Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.PasteSpecial Transpose:=True
Next j
kL = Sheets("COMPARE").Range("A" & Rows.Count).End(xlUp).Row
lRows = Sheets("COMPAREOBD").Cells(Rows.Count, 1).End(xlUp).Row
For j = 3 To 4
For k = 2 To kL
Set rng1 = Sheets("COMPAREOBD").Range("A" & i)
Set rng2 = Sheets("COMPAREOBD").Columns(j)
var = Application.Match(rng1.Value, rng2, 1)
If Not IsError(Application.Match(rng1.Value, rng2, 0)) Then bln = True
If bln = True Then
rng1.Interior.Color = RGB(255, 255, 0)
rng1.Copy
rng1.Offset(0, 1).Font.Name = "Wingdings"
rng1.Offset(0, 1).Value = ChrW(&HFC)
End If
End If
Next k
Set rng1 = Nothing
Set rng2 = Nothing
Sheets("COMPAREOBD").Range(Cells(1, 2), Cells(lRows, "B")).Copy
Sheets("COMPAREFINALOBD").Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.PasteSpecial Transpose:=True
Next j
End Sub
the main slow down here i see is that you are checking one cell at a time with the MATCH formula, if your "iL" is more than in double digits it will be in fact very slow. Is the alternative possible where you just populate a column next to your full range with the MATCH formula and work off that?