2 different Ranges Compare from different Sheets not Working VBA - vba

Why isnt this text Compare working? I'm trying to compare 2 different ranges from different sheets.
Is there a good simple way of doing this?
Sub selecttest()
Text3 = Sheets("Input DATA").Range(Cells(2, 2), Cells(2, Columns.Count).End(xlToLeft))
Text4 = Sheets("SAP Output DATA").Range(Cells(3, 1), Cells(Rows.Count, 1).End(xlUp))
If StrComp(Text3, Text4, vbTextCompare) = 0 Then
Else
Cells(Cell.Row, "A").Interior.ColorIndex = 26
Cells(Cell.Row, "B").Interior.ColorIndex = 26
Cells(Cell.Row, "C").Interior.ColorIndex = 26
Cells(Cell.Row, "D").Interior.ColorIndex = 26
End If
End Sub
Is there something that im doing incorrectly?
Also tried this with no errors but it wont solve:
Sub comprangetest()
With ThisWorkbook.Sheets("Input DATA")
Text3 = Range(Cells(2, 2), Cells(2, Columns.Count).End(xlToLeft)).Select
End With
With ThisWorkbook.Sheets("SAP Output DATA")
Text4 = Sheets("SAP Output DATA").Range(Cells(3, 1), Cells(Rows.Count, 1).End(xlUp)).Select
End With
'Text3 = Sheets("Input DATA").Range(Cells(2, 2), Cells(2, Columns.Count).End(xlToLeft))
'Text4 = Sheets("SAP Output DATA").Range(Cells(3, 1), Cells(Rows.Count, 1).End(xlUp))
If StrComp(Text3, Text4, vbTextCompare) = 0 Then
Else
ActiveSheet.Cells(Cell.Row, "A").Interior.ColorIndex = 26
ActiveSheet.Cells(Cell.Row, "B").Interior.ColorIndex = 26
ActiveSheet.Cells(Cell.Row, "C").Interior.ColorIndex = 26
ActiveSheet.Cells(Cell.Row, "D").Interior.ColorIndex = 26
End If
End Sub
Am i using the correct method?

Instead of comparing from different sheets, i just brought the range over to the current sheet and made it a requirement to use a selection before the compare initiates. Since the source range is on a row, i used k as the integer for where the source is. The source always changes and is always above the selection. so that line is used for the compare. Of coarse i can probably now even go further and create a selection range from another sheet. But this works for me now. I hope i saved some time for other people struggling with this as i was.
Sub CompareRanges()
application.ScreenUpdating = False
Dim Report As Worksheet
Dim i As Integer, j As Integer, k As Integer
Dim lastrow As Integer
Dim LastColumn As Integer
Dim sht As Worksheet
Dim cell As Range
Dim x As Long, y As Long
Set sht = ThisWorkbook.Sheets("SAP Output DATA")
lastrow = sht.UsedRange.Rows.Count
LastColumn = sht.UsedRange.Columns.Count
'If Selection Is Nothing Then
'MsgBox "nothing selected, please select range."
'Else
'x is the first row number of selection, y is the last.
x = Selection.Rows(1).row
y = Selection.Rows.Count + x - 1
'MsgBox x & " " & y
'give row number of cell above selection.
k = Selection.Rows(1).Offset(-1, 0).row
'MsgBox k
For i = x To y 'lastrow
'For i = 3 To lastrow 'lastrow
For j = 5 To LastColumn
If sht.Cells(i, 1).Value <> "" Then 'This will omit blank cells at the end (in the event that the column lengths are not equal.
'sht.cell (2, j) "k is the variable for where is the source."
If InStr(1, sht.Cells(k, j).Value, sht.Cells(i, 1).Value, vbTextCompare) > 0 Then
sht.Cells(i, 1).Interior.Color = RGB(255, 255, 255) 'White background
sht.Cells(i, 1).Font.Color = RGB(0, 0, 0) 'Black font color
Exit For
Else
sht.Cells(i, 1).Interior.Color = RGB(156, 0, 6) 'Dark red background
sht.Cells(i, 1).Font.Color = RGB(255, 199, 206) 'Light red font color
End If
End If
Next j
Next i
'End If
application.ScreenUpdating = True
End Sub

Related

VBA Vlookup mismatch

I have cells to look for in sheet4 and the lookup table is in sheet2 Range("A16:B25"). When I run this code it is giving me a mismatch error. Why is it doing this?
Dim i As Integer
Dim lrow As Long
Dim x As Integer
Sheet4.Activate
lrow = Sheet4.Range("A" & Rows.count).End(xlUp).Row
For i = 2 To lrow
Cells(i, 1).Activate
x = Application.VLookup(ActiveCell.Offset(0, 0).Value, Worksheets(2).Range("A16:B25"), 2, False)
If x <> Cells(i, 2).Value Then
Cells(i, 2).Interior.Color = RGB(255, 0, 0)
Else
End If
Next i
1: You do not need to activate anything unless it is absolutely necessary. Use explicit references (workbook.worksheet.cell or .range)
2: You need to check if your vlookup is returning an error.
3: ActiveCell.Offset(0, 0).Value is just the activecell since you have no offset.
Try to get this into your code, you may have to adjust things for your specific use.
sub lookup_color()
Dim i As Integer
Dim lrow As Long
Dim vReturnVal As Variant
lrow = Sheet4.Range("A" & Rows.count).End(xlUp).Row
For i = 2 To lrow
vReturnVal = Application.VLookup(Sheet4.Cells(i, 1).Value, Worksheets(2).Range("A16:B25"), 2, False)
If Not IsError(vReturnVal) Then
If vReturnVa <> Sheet4.Cells(i, 2).Value Then
Sheet4.Cells(i, 2).Interior.Color = RGB(255, 0, 0)
End If
End iF
Next i
End sub

Coloring a line where macro finds a certain word

I'd like to know if there's a way to do the following thing using VBA:
If the macro finds the word "Total" in the column B, then interior.color of the line where total is would be colored in Blue, and do it for all the "Total" words in the column B.
Note: I have different Totals... it's not only the word "Total"
LIKE THIS (i.e coloring from col A to F)
I tried with this but it's not working properly and the code is bad...
Sub forme_couleur()
Dim myRow As Integer
myRow = 1
While Not IsEmpty(Cells(myRow, 2))
If Cells(myRow, 2).Find(What:="Total") Is Nothing Then
myRow = myRow + 1
Else
Cells(myRow, 2).Find(What:="Total").Interior.Color = RGB(174, 240, 194)
End If
myRow = myRow + 1
Wend
End Sub
Consider:
Sub ColorMeBlue()
Dim i As Long, N As Long, s As String
N = Cells(Rows.Count, "B").End(xlUp).Row
s = "Total"
For i = 1 To N
If InStr(1, Cells(i, 2).Value, s) > 0 Then
Range("A" & i & ":F" & i).Interior.Color = RGB(174, 240, 194)
End If
Next i
End Sub
EDIT#1:
To refer to a range using columns by number, use:
Sub ColorMeBlue2()
Dim i As Long, N As Long, s As String
N = Cells(Rows.Count, "B").End(xlUp).Row
s = "Total"
Firstcol = 1
LastCol = 6
For i = 1 To N
If InStr(1, Cells(i, 2).Value, s) > 0 Then
Range(Cells(i, Firstcol), Cells(i, LastCol)).Interior.Color = RGB(174, 240, 194)
End If
Next i
End Sub
You can achieve this with conditional formatting, but if you must do it with VBA use something like the following:
Sub test()
For i = 1 To Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
If InStr(1, Cells(i, 2), "Total") Then
With Cells(i, 2).EntireRow.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
End If
Next i
End Sub
Another Concept: You can go with the AutoFilter method. Using this method doesn't require any For loops, or any Ifs, just use all the cells that passes the AutoFilter criteria of ="*Total*" inside your Range.
Sub ColorMeBlue_Filter()
Dim i As Long, N As Long, s As String
Dim FirstCol As Long, LastCol As Long
Dim FiltRng As Range
N = Cells(Rows.Count, "B").End(xlUp).Row
s = "Total"
' (just for my testing)
'FirstCol = 1
'LastCol = 6
Range("A1").AutoFilter
Range(Cells(1, FirstCol), Cells(N, LastCol)).AutoFilter Field:=2, Criteria1:="=*Total*", _
Operator:=xlAnd
' set FiltRng to only visible cells (that passed the "Total" filter)
Set FiltRng = Range(Cells(2, FirstCol), Cells(N, LastCol)).SpecialCells(xlCellTypeVisible)
' modify interior color of all cells at once (one code line)
FiltRng.Interior.Color = RGB(174, 240, 194)
End Sub
You can do with a formula based conditional formatting, using the COUNTIF(a1:f1,"Total") function being >0
Using Range.Find avoids: looping through each row and the need to get the last row.
Instead of applying Range.Find to each row, just apply it to the entire column, no need to check if the cell is empty (see Range.Find Method (Excel) for additional details)
Voici votre code révisé:
Assuming your data is located at `A:F'
Sub forme_couleur()
Const kCriteria As String = "Total"
Dim rTrg As Range, s1stFound As String
With ThisWorkbook.Sheets("DATA").Columns(2) 'change as required
Set rTrg = .Cells.Find(What:=kCriteria, After:=.Cells(1), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not (rTrg Is Nothing) Then
s1stFound = rTrg.Address
Do
rTrg.EntireRow.Cells(1).Resize(1, 6).Interior.Color = RGB(224, 240, 248) 'RGB(174, 240, 194) give me a green color - changed as required
Set rTrg = .Cells.FindNext(After:=rTrg)
Loop Until rTrg.Address = s1stFound
End If: End With
End Sub

Color non-adjacent cells that match criteria

I use the below code to color the cells in column K and Z that match the criteria; but it colors all cells between K and Z. To fix, I use the last line of code to remove the color in columns L thru Y. Is there a way to modify the line of code that starts with "Range" to only color cells K and Z that match the criteria?
Sub ColrCls()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("K" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
If .Cells(i, 11).Value = "Non Sen" And .Cells(i, 26).Value = "N/A" Then
Range(.Cells(i, 11), .Cells(i, 26)).Interior.ColorIndex = 6
End If
Next i
Columns("L:Y").Interior.ColorIndex = xlNone
End With
End Sub
You are specifying the Range.Parent property in your With ... End With statement but ignoring it when it is most important¹.
Sub ColrCls()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("K" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
If .Cells(i, 11).Value = "Non Sen" And .Cells(i, 26).Value = "N/A" Then
.Range("K" & i & ", Z" & i).Interior.ColorIndex = 6
Else
.Range("K" & i & ", Z" & i).Interior.Pattern = xlNone
End If
Next i
End With
End Sub
A Range object to Union discontiguous cells could be one of the following.
.Range("K5, Z5")
Union(.Cells(5, "K"), .Cells(5, "Z"))
In the example above, I've concatenated together a string like the first of these two examples.
¹ See Is the . in .Range necessary when defined by .Cells? for an earnest discussion on this subject.
You could replace
Range(.Cells(i, 11), .Cells(i, 26)).Interior.ColorIndex = 6
with
.Cells(i, 11).Interior.ColorIndex = 6
.Cells(i, 26).Interior.ColorIndex = 6

How could I add this to an array?

I've been trying to add the entire row that meets the highlight criteria to an array but I've been struggling getting it to work.
The code loops through multiple identifiers and highlight them in red based off of the preconditions. I would like to add the entire row to an array for all rows meeting the precondition criteria.
Sub SWAPS101()
'red color
' If "Security Type" = SW
' If "New Position Ind" = N
' If "Prior Price" = 100
' If "Current Price" does not equal 100
Dim rng As Range, lCount As Long, LastRow As Long
Dim cell As Object
'Sheets("Output").Activate
With ActiveSheet
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For Each cell In .Range("E2:E" & LastRow) 'new position
If cell = "N" And cell.Offset(, 16) = "SW" And cell.Offset(, 5) = 100 _
And cell.Offset(, 4) <> 100 Then
With cell.EntireRow.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 6382079
.TintAndShade = 0
.PatternTintAndShade = 0
End With
' LastRow = Range("b65000").End(xlUp).Row
' For r = 2 To LastRow
Row = Row + 1
TempArray(Row, 1) = Cells(r, cell))
Next r
End If
Next cell
End With
End Sub
Using the Range.CurrentRegion property to isolate the 'island' of data radiating out from A1 is an easy method to restrict the 'scope' of the operation. You do not want to be copying thousands of blank cells into an array.
Sub SWAPS101()
'red color
' If "Security Type" = SW
' If "New Position Ind" = N
' If "Prior Price" = 100
' If "Current Price" does not equal 100
Dim a As Long, r As Long, c As Long, vVALs As Variant
With Sheets("Output")
'reset the environment
If .AutoFilterMode Then .AutoFilterMode = False
.Columns(5).Interior.Pattern = xlNone
With .Cells(1, 1).CurrentRegion
ReDim vVALs(1 To .Columns.Count, 1 To 1)
.AutoFilter field:=Application.Match("security type", .Rows(1), 0), Criteria1:="SW"
.AutoFilter field:=Application.Match("new position ind", .Rows(1), 0), Criteria1:="N"
.AutoFilter field:=Application.Match("prior price", .Rows(1), 0), Criteria1:=100
.AutoFilter field:=Application.Match("current price", .Rows(1), 0), Criteria1:="<>" & 100
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
'check to ensure that there is something to work with
If CBool(Application.Subtotal(103, .Cells)) Then
With Intersect(.Columns(5), .SpecialCells(xlCellTypeVisible))
.Cells.Interior.Color = vbRed
End With
Debug.Print .SpecialCells(xlCellTypeVisible).Areas.Count
With .SpecialCells(xlCellTypeVisible)
For a = 1 To .Areas.Count
Debug.Print .Areas(a).Rows.Count
For r = 1 To .Areas(a).Rows.Count
Debug.Print .Areas(a).Rows(r).Address(0, 0)
ReDim Preserve vVALs(1 To UBound(vVALs, 1), 1 To UBound(vVALs, 2) + 1)
For c = 1 To .Columns.Count
vVALs(c, UBound(vVALs, 2)) = _
.Areas(a).Rows(r).Cells(1, c).Value
Next c
Next r
Next a
vVALs = Application.Transpose(vVALs)
End With
'array is populated - do something with it
Debug.Print LBound(vVALs, 1) & ":" & UBound(vVALs, 1)
Debug.Print LBound(vVALs, 2) & ":" & UBound(vVALs, 2)
'this dumps the values starting a couple of rows down
With .Cells(.Rows.Count, 1).Offset(3, 0)
.Resize(UBound(vVALs, 1), UBound(vVALs, 2)) = vVALs
End With
End If
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
I've left a lot of the debug.print statements in so you can watch how the process loops through the rows of each Range.Areas property within the Range.SpecialCells method's xlCellTypeVisible set. Use F8 to step through the code while keeping an eye on the VBE's Immediate window ([Ctrl]+G).
                        Post-processing results
You can add ranges to an array, such as:
Dim myArray() As Variant 'declare an unallocated array.
myArray = Range("E2:E" & LastRow) 'myArray is now an allocated array, range being your row
My idea is to create union range uRng but I couldn't fill it in array so create temp sheet and past this range in it then fill the selection (the copied range) in array then delete this temp sheet.
this will work but I don't know if it is good way so this is just an idea because Jeeped answer seems the full answer for this question
Sub SWAPS101()
'red color
' If "Security Type" = SW
' If "New Position Ind" = N
' If "Prior Price" = 100
' If "Current Price" does not equal 100
Dim rng As Range, lCount As Long, LastRow As Long
Dim cell As Range
Dim TempArray As Variant, uRng As Range, tempSH As Worksheet
'Sheets("Output").Activate
With ActiveSheet
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For Each cell In .Range("E2:E" & LastRow) 'new position
If cell = "N" And cell.Offset(, 16) = "SW" And cell.Offset(, 5) = 100 _
And cell.Offset(, 4) <> 100 Then
With cell.EntireRow.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 6382079
.TintAndShade = 0
.PatternTintAndShade = 0
End With
If uRng Is Nothing Then
Set uRng = cell.EntireRow
Else
Set uRng = Union(uRng, cell.EntireRow)
End If
End If
Next cell
End With
If Not uRng Is Nothing Then
Application.ScreenUpdating = False
Set tempSH = Sheets.Add
uRng.Copy
tempSH.Paste
TempArray = Selection.Value
Application.DisplayAlerts = False
tempSH.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
End Sub

How do I loop through workbooks performing the same function in each?

I've been trying to create a macro that extracts specific cell data from several open workbooks that all contain a specific sheet named ("Report_Final")
Currently, my macro goes sth like this:
Sub PerLineItem()
'Main function i'm trying to call for each open workbook
Dim wb As Workbook
Dim ws, ws2 As Worksheet
Dim i, j, k, x, rng As Integer
Dim temp_total As Double
Dim mat_name1, mat_name2 As String
i = 2
j = 2
k = 2
rng = 0
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
Sheets.Add
Set ws = ActiveSheet
'Intermediate sheet to filter only columns 2, 11 & 18'
ws.Name = "Report"
Cells(1, 2) = "WBS"
Cells(1, 3) = "Material"
Cells(1, 4) = "Sell Total Price"
Sheets("zero250").Select
Do While Cells(i, 2) <> ""
rng = rng + 1
i = i + 1
Loop
'Copy and paste columns 2, 11, 18 to 2, 3, 4 in the new sheet("Report")
Do While j < rng
If ((Right(Cells(j, 2), 3) = "RTN") Or (Right(Cells(j, 2), 3) = "NRT")) Then
Union(Cells(j, 2), Cells(j, 11), Cells(j, 18)).Copy
Sheets("Report").Select
Union(Cells(k, 2), Cells(k, 3), Cells(k, 3)).Select
ActiveSheet.Paste
Sheets("zero250").Select
k = k + 1
End If
j = j + 1
Loop
'Create new sheet to group up identical named materials and sum the value up
Sheets.Add
Set ws2 = ActiveSheet
'The debugger always points to the below line "name is already taken" since it is being run in the same workbook
ws2.Name = "Report_Final"
Sheets("Report").Select
i = 2
j = 2
k = 2
x = 2
rng = 1
Do While Cells(i, 2) <> ""
rng = rng + 1
i = i + 1
Loop
'deletes identicals names and sums the value up, puts the values onto sheet("Report_final")
Do While j <= rng
If Cells(j, 3) <> "" Then
mat_name1 = Cells(j, 3).Value
temp_total = Cells(j, 4).Value
For x = j To rng
mat_name2 = Cells(x + 1, 3).Value
If mat_name2 = mat_name1 Then
temp_total = temp_total + Cells(x + 1, 4).Value
Rows(x + 1).ClearContents
End If
Next x
Sheets("Report_Final").Select
Cells(k, 2) = mat_name1
Cells(k, 3) = temp_total
Sheets("Report").Select
Rows(j).ClearContents
k = k + 1
j = j + 1
Else
j = j + 1
End If
Loop
'Labels the new columns in "Report_Final" and calculates the grand total
ws2.Select
Cells(1, 1).Value = wb.Name
Cells(1, 2).Value = "Material"
Cells(1, 3).Value = "Sell Total Price"
Cells(k, 3).Value = Application.Sum(Range(Cells(2, 3), Cells(k, 3)))
Application.DisplayAlerts = False
'Deletes intermediate sheet "Report"
Sheets("Report").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
In my Main function where I use:
For each wb in Workbooks
PerLineItem
Next wb
It doesn't call PerLineItem for each of the open workbooks but instead trys to perform the function again on the same workbook.
P.S I know there may be a easier way to write all this code but I do not know prior knowledge to VBA :(
Edit : Hi so I've used your code with a little modification and it works fine! But now when i add this next part, it only works through the last workbook, as the counter k does not seem to loop for the earlier workbooks
'~~> cleaning up the sheet still goes here
With wb.Sheets("Report")
rng2 = .Range("B" & .Rows.Count).End(xlUp).Row
MsgBox rng2
Do While j <= rng2
If Cells(j, 3) <> "" Then
mat_name1 = .Cells(j, 3).Value
temp_total = .Cells(j, 4).Value
For x = j To rng2
mat_name2 = .Cells(x + 1, 3).Value
If mat_name2 = mat_name1 Then
temp_total = temp_total + .Cells(x + 1, 4).Value
.Rows(x + 1).ClearContents
End If
Next x
.Rows(j).ClearContents
.Cells(k, 2) = mat_name1
.Cells(k, 3) = temp_total
k = k + 1
j = j + 1
Else
j = j + 1
End If
Loop
MsgBox k
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
P.S I've decided to scrap creating another worksheet and work within "Report"
Try this:
Dim wb As Workbook
For Each wb in Workbooks
If wb.Name <> Thisworkbook.Name Then
PerLineItem wb
End If
Next
Edit1: You need to adapt your sub like this
Private Sub PerLineItem(wb As Workbook)
Dim ws As Worksheet, ws2 As Worksheet
Dim i As Long, j As Long, k As Long, x As Long, rng As Long
Dim temp_total As Double
Dim mat_name1 As string, mat_name2 As String
i = 2: j = 2: k = 2: rng = 0
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'~~> Improve initializing ws
Set ws = wb.Sheets.Add(wb.Sheets(1))
ws.Name = "Report"
'~~> Directly work on your object; You can also use the commented lines
With ws
.Cells(1, 2) = "WBS" '.Range("B1") = "WBS"
.Cells(1, 3) = "Material" '.Range("C1") = "Material"
.Cells(1, 4) = "Sell Total Price" '.Range("D1") = "Sell Total Price"
End With
'~~> Same with the other worksheet
With wb.Sheets("zero250")
rng = .Range("B" & .Rows.Count).End(xlUp).Row
.AutoFilterMode = False
.Range("B1:B" & rng).AutoFilter 1, "=*RTN*", xlOr, "=*NRT*"
.Range("B1:B" & rng).Offset(1,0).SpecialCells(xlCellTypeVisisble).Copy _
ws.Range("B" & ws.Rows.Count).End(xlup).Offset(1,0)
End With
'~~> cleaning up the sheet still goes here
End Sub
Above code is the equivalent of your code up to generating the Report Sheet only.
Can you continue? :) I run out of time. ;p
Btw, hope this helps.