I wrote this code over the weekend and it was blazing fast, when I got to work on Monday I sent an email before testing the code while servers had a load and it is infinitely slower. We are talking from 30 seconds to 15 minutes.
For x = 3 To SRLastRow
If Left(shMacro.Range("D" & x), 3) = "625" Then
shMacro.Range("BW" & x) = WorksheetFunction.XLookup(Arg1:=shMacro.Range("A" & x), Arg2:=WIPFile.Worksheets("Customer Master").Range("B:B"), Arg3:=WIPFile.Worksheets("Customer Master").Range("AD:AD"))
Else
shMacro.Range("BW" & x) = WorksheetFunction.XLookup(Arg1:=shMacro.Range("A" & x), Arg2:=WIPFile.Worksheets("Customer Master").Range("B:B"), Arg3:=WIPFile.Worksheets("Customer Master").Range("AH:AH"))
End If
If shMacro.Range("BW" & x) <> shMacro.Range("BX" & x) Then
shMacro.Range("BX" & x).Interior.ColorIndex = 3
ErrorCount = ErrorCount + 1
End If
Next x
I essentially need to pull in a value, then compare that pulled in value with a value on my Macro worksheet. If the values match do nothing, otherwise color the cell red.
I came up with the following, but haven't tested it fully yet, but the problem remains having to cycle through to find mismatches to color them.
shMacro.Range("BW3").Formula = "=IF(LEFT(D3,3)=""625"",XLOOKUP(TEXT(A3,""000""),'[WORKBOOK]Customer Master'!$AD:$AD),XLOOKUP(TEXT(A3,""000""),'[WORKBOOK]Customer Master'!$B:$B,'[WORKBOOK]Customer Master'!$AH:$AH))"
Range("BW3").AutoFill Destination:=Range("BW3:BW" & SRLastRow)
I've also tried looking into Arrays but I can't seem to figure those out. I think the autofill would be the fastest way to pull in the data, then somehow assign the two arrays (which would be columns BW and BX) and if they match do nothing, wherever they are different color BX + row reference red, and count the number of times it colored something red.
Should be a little faster (reducing cell reads without going "full array mode" and coloring all mismatches in one shot)
Sub Tester()
Dim x As Long, SRLastRow As Long
Dim colReturn As String, v, rngRed As Range, rw As Range
'...
'...
'...
Application.ScreenUpdating = False
For x = 3 To SRLastRow
Set rw = shMacro.Rows(x)
colReturn = IIf(Left(rw.Columns("D").Value, 3) = "625", "AD:AD", "AH:AH")
v = Application.XLookup( _
Arg1:=rw.Columns("A").Value, _
Arg2:=WIPFile.Worksheets("Customer Master").Range("B:B"), _
Arg3:=WIPFile.Worksheets("Customer Master").Range(colReturn))
If Not IsError(v) Then
rw.Columns("BW").Value = v
With rw.Columns("BX")
If v <> .Value Then
BuildRange rngRed, .Cells(1)
ErrorCount = ErrorCount + 1
End If
End With
End If
Next x
'color the mismatches if any
If Not rngRed Is Nothing Then rngRed.Interior.ColorIndex = 3
End Sub
'utility - build a range using Union
Sub BuildRange(ByRef rngTot As Range, rngAdd As Range)
If rngTot Is Nothing Then
Set rngTot = rngAdd
Else
Set rngTot = Application.Union(rngTot, rngAdd)
End If
End Sub
I think the reason for the slow processing is in the location of the WIPFile workbook. Therefore my code below minimizes the need to access it. I couldn't test my code for lack of data but I hope you will try it.
Sub Snippet()
' 214
Dim LookUpRng As Range ' in "Customer Master"
Dim ReturnVals As Variant ' values from "Customer Master"
Dim C As Long ' Lookup column in ReturnRng
Dim Fnd As Range ' search result
Dim x As Long ' loop counter: rows (why "x" and not "R" ?)
Dim ErrorCount As Variant
Dim Spike As String ' collect failed lookups
ErrorCount = 0
With WIPFile.Worksheets("Customer Master")
Set LookUpRng = .Columns("BB")
ReturnVals = .Range(.Columns("AD"), .Columns("AH")).Value
End With
With shMacro
For x = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
Set Fnd = LookUpRng.Find(.Cells(x, "A").Value, LookIn:=xlValues, LookAt:=xlWhole)
If Fnd Is Nothing Then
If Len(Spike) Then Spike = Spike & vbCr
Spike = Spike & String(6, " ") & """" & .Cells(x, 1).Value & """ in row " & x
Else
C = IIf(Left(.Cells(x, "D").Value, 3) = "625", 1, 5)
With .Cells(x, "BW")
.Value = ReturnVals(Fnd.Row, C)
If .Value <> .Cells(x, "BX").Value Then
.Interior.ColorIndex = 3
ErrorCount = ErrorCount + 1
End If
End With
End If
Next x
End With
If Len(Spike) Then
Spike = "The following look-ups were not successful." & vbCr & _
Spike & IIf(ErrorCount, vbCr, "")
Else
Spike = "All look-ups were successful."
End If
If ErrorCount = 0 Then ErrorCount = "No"
Spike = Spike & vbCr & ErrorCount & " matching error" & _
IIf(ErrorCount = 1, "", "s") & " were highlighted."
MsgBox Spike, vbInformation, "Action report"
End Sub
If my approach shows promise more speed could be gained by reading column B:B into another array and use a MATCH function instead of Find. In that way "Customer Master" would need to be accessed only once. Of course, you could also gain a little time by suspending ScreenUpdating during execution.
No VBA required. Use Formula + Conditional formatting
Entering the formula
Put this formula in BW3 and copy it down. Change SAMPLE.xlsx to the relevant file.
=IF(LEFT(D3,3)=625,XLOOKUP(A3,'[SAMPLE.xlsx]Customer Master'!$B:$B,'[SAMPLE.xlsx]Customer Master'!$AD:$AD),XLOOKUP(A3,'[SAMPLE.xlsx]Customer Master'!$B:$B,'[SAMPLE.xlsx]Customer Master'!$AH:$AH))
Setting up Conditional Formatting
Select the relevant range, starting for row 3.
Click on Home | Conditional formatting | New Rule | Use formula to determine which cells to format
Enter the formula =BW3<>BX3 and set the relevant color.
And you are done.
If you still want VBA then also you do not need any kind of loop or Autofill. You can enter the formula via VBA in all the cells in 1 GO! Here is an example (UNTESTED)
With shMacro
lrow = .Range("D" & .Rows.Count).End(xlUp).Row
.Range("BW3:BW" & lrow).Formula = "=IF(LEFT(D3,3)=625,XLOOKUP(A3,'[SAMPLE.xlsx]Customer Master'!$B:$B,'[SAMPLE.xlsx]Customer Master'!$AD:$AD),XLOOKUP(A3,'[SAMPLE.xlsx]Customer Master'!$B:$B,'[SAMPLE.xlsx]Customer Master'!$AH:$AH))"
End With
For conditional formatting you can use this code
With shMacro.Range("BW3:BW" & lrow)
.FormatConditions.Add Type:=xlExpression, Formula1:="=BW3<>BX3"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
.FormatConditions(1).StopIfTrue = False
End With
So basically your entire code can be written as
With shMacro
lrow = .Range("D" & .Rows.Count).End(xlUp).Row
With .Range("BW3:BW" & lrow)
.Formula = "=IF(LEFT(D3,3)=625,XLOOKUP(A3,'[SAMPLE.xlsx]Customer Master'!$B:$B,'[SAMPLE.xlsx]Customer Master'!$AD:$AD),XLOOKUP(A3,'[SAMPLE.xlsx]Customer Master'!$B:$B,'[SAMPLE.xlsx]Customer Master'!$AH:$AH))"
DoEvents
.FormatConditions.Add Type:=xlExpression, Formula1:="=BW3<>BX3"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
.FormatConditions(1).StopIfTrue = False
End With
End With
Related
I have a problem with the following code. I have data in columns A and C and want to find matching pairs that are identical in these two columns (column A and C). The pairs should receive an unique identifier in column B and D. This way I can filter out corresponding pairs from column A and C and have two remaining columns that cannot be matched. However, my code keeps looping trough the data when there are duplicates within a column and keeps assigning higher reference numbers.
Sub match()
Dim c As Range, fn As Range, ref As Long
ref = 1
For Each c In Range("A2", Cells(Rows.Count, 1).End(xlUp))
If c <> "" And c <> 0 Then
Set fn = Range("C2", Cells(Rows.Count, 3).End(xlUp)).Find(c.Value, , xlValues, xlWhole)
If Not fn Is Nothing Then
adr = fn.Address
Do
If fn.Offset(, 1) = "" Then
c.Offset(, 1) = ref
fn.Offset(, 1) = ref
ref = ref + 1
Else
Set fn = Range("C2", Cells(Rows.Count, 3).End(xlUp)).FindNext(fn)
End If
Loop While fn.Address <> adr
End If
End If
Next
On Error Resume Next
Range("B2", Cells(Rows.Count, 1).End(xlUp).Offset(, 1)).SpecialCells(xlCellTypeBlanks) = "Not found"
Range("D2", Cells(Rows.Count, 3).End(xlUp).Offset(, 1)).SpecialCells(xlCellTypeBlanks) = "Not Found"
On Error GoTo 0
Err.Clear
End Sub
Does anyone know a solution?
You may benefit from MATCH in array form with Evaluate to fill the column D. The column B is the easy part, just MAX+1
Sub TEST()
Dim i As Long, j As Long
Dim rng_c As Range
Dim rng_b As Range
Dim LR As Long
Dim SR As Long
Dim Myf As WorksheetFunction
Set Myf = Application.WorksheetFunction 'to save some time typing
SR = 1 'starting row of data
LR = Range("A" & Rows.Count).End(xlUp).Row 'last row of data in column A
Set rng_b = Range("B" & SR & ":B" & LR) ' for column B
Set rng_c = Range("C" & SR & ":C" & LR) ' for column C
rng_b.Clear 'must be empty
Range("D" & SR & ":d" & LR).Clear 'must be empty
For i = SR To LR Step 1
If Myf.CountIf(rng_c, Range("A" & i).Value) = 0 Then
Range("B" & i).Value = "Not found"
Else
Range("B" & i).Value = Myf.Max(rng_b) + 1
End If
Next i
j = SR
For i = SR To LR Step 1
If Range("B" & i).Value <> "Not found" Then
j = Evaluate("MATCH(A" & i & ",C" & SR & ":C" & LR & "&D" & SR & ":D" & LR & ",0)")
Range("D" & j).Value = Range("B" & i).Value
End If
Next i
Set rng_b = Nothing
Set rng_c = Nothing
Set Myf = Nothing
End Sub
You could do this without VBA at all, actually.
In D2, write this Formula:
=IF(COUNTIFS($A:$A, $A2, $C:$C, $C2)>1, IF(COUNTIFS($A$1:$A2, $A2, $C$1:$C2, $C2)=1, MAX($D$1:$D1)+1, XLOOKUP($A2 & $C2, $A$1:$A1 & $C$1:$C1, $D$1:$D1)), "Not Found")
Then copy that down column D, and make column B equal to column D
There are several ways of doing this, but you were nearly there!
Here are some slight adjustments:
Sub match()
'''screenupdating false, calc to manual to speed up code
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim c As Range, fn As Range, ref As Long
'setting your ranges for clarity
Dim rng As Range, rng2 As Range
Set rng = Range("A2", Cells(Rows.Count, 1).End(xlUp))
Set rng2 = Range("C2", Cells(Rows.Count, 3).End(xlUp))
'''necessary for rerunning
rng.Offset(0, 1).ClearContents
rng2.Offset(0, 1).ClearContents
ref = 1
For Each c In rng
If c <> "" And c <> 0 Then
'adding After:=rng2.Cells.Count
Set fn = rng2.Find(c.Value, rng2.Cells(rng2.Cells.Count), xlValues, xlWhole)
If Not fn Is Nothing Then
''' placed this back here
adr = fn.Address
Do
'''
'place inside Do ... Loop While
'''adr = fn.Address
'''
If fn.Offset(, 1) = "" Then
c.Offset(, 1) = ref
fn.Offset(, 1) = ref
ref = ref + 1
''' but we do need it here to get out of infinite loop
''' in case
adr = fn.Address
Else
Set fn = rng2.FindNext(fn)
End If
Loop While fn.Address <> adr
End If
End If
Next
On Error Resume Next
Range("B2", Cells(Rows.Count, 1).End(xlUp).Offset(, 1)).SpecialCells(xlCellTypeBlanks) = "Not found"
Range("D2", Cells(Rows.Count, 3).End(xlUp).Offset(, 1)).SpecialCells(xlCellTypeBlanks) = "Not found" '''minor correction: "Not found" (F -> f)
On Error GoTo 0
Err.Clear
'''screenupdating true again, calc to auto
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Problem 1: you forget to add the After parameter in .Find(...). See Using the .Find Function VBA - not returning the first value on why you need it.
Problem 2: the statement adr = fn.Address should be inside the Do ... Loop While, else you won't step out of the loop until after the last match; as a result you just kept overwriting the value in c.Offset(, 1) for A8 (leading to 6) and adding values for all its matches in column C (which explains values 4, 5, 6).
Edit: Problem 2 in the strikethrough text above was real, my suggestion on how to fix it quite ignorant. It will cause an infinite loop for a duplicate in rng that does have one or more matches in rng2, but less matches than its own count in rng. E.g. if rng has x 3 times, and rng2 has x twice, the code will loop forever when it gets to the 3rd x and crash Excel. So sorry. Pure luck that the dummy data didn't contain such an example.
Correct solution: keep adr = fn.Address were it was, but add the same statement inside the If fn.Offset(, 1) = "" Then statement. Now, it should work. Code above updated. Triple apostrophes in the code indicate corrections. Added some minor syntax for better performance.
However, as I was testing on a much larger set, I noticed this code was slow. I've found a rather different solution with much better performance, which I will post as a different answer in a sec (in accordance with SO etiquette.
In my other answer I focused on improving your initial code, since you almost got there yourself, and I think one should encourage people's efforts. However, on a larger set, performance wasn't great, so I had a look to see if we could find improvement with a different method. The answer, I think, is "yes". The following solution stores the values from rng2 in an array and on every match alters that match within the array (by adding Chr(1) & ref to the init value). At the end we use another loop to populate rng2.Offset(,1) with the refs through Split()(1) . This way, each new match will simply be the correct match for the new pair, thus avoiding many unnecessary .find commands. Below comparison of 2 tests.
In this snippet "Find_method" refers to code in other answer, "Array_method" refers to answer below.
I'd say, we have ourselves a clear winner. Suggestions for further improvement are of course welcome! Code as follows, with added comments to explain what it does:
Sub matchPairs()
'screenupdating false, calc to manual to speed up code
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim c As Range, fn As Range
Dim ref As Long, c_match As Long, i As Long
Dim rng As Range, rng2 As Range
'set ranges
Set rng = Range("A2", Cells(Rows.Count, 1).End(xlUp))
Set rng2 = Range("C2", Cells(Rows.Count, 3).End(xlUp))
'clear offsets (not strictly necessary for rerun)
rng.Offset(0, 1).ClearContents
rng2.Offset(0, 1).ClearContents
'drop rng2 inside array
Dim DirArray() As Variant
DirArray = Application.Transpose(rng2.Value)
ref = 1 'counter
'looping through init rng
For Each c In rng
'get position match c.Value in DirArray; will throw error if no match
On Error Resume Next
c_match = Application.match(c.Value, DirArray, 0)
'handle error
If Err.Number <> 0 Then
c_match = 0
'reset error handling
Err.Clear
On Error GoTo 0
End If
If c_match = 0 Then
'no match
c.Offset(, 1) = "Not found"
Else
'assign counter
c.Offset(, 1) = ref
'alter match in array, so it won't show up as a match again
'Chr(1) (Start of Header, non-printable ASCII char) won't occur in your data
'we can use it as the delimiter for Split below
DirArray(c_match) = DirArray(c_match) & Chr(1) & ref
'increment counter
ref = ref + 1
End If
Next
'loop over array, and check for presence Chr(1) in each value
For i = LBound(DirArray) To UBound(DirArray)
If InStr(DirArray(i), Chr(1)) = 0 Then
'we didn't alter this entry: it was never found
rng2.Cells(i).Offset(, 1) = "Not found"
Else
'Chr(1) present, get second value from Split array, and put in the offset
rng2.Cells(i).Offset(, 1) = Split(DirArray(i), Chr(1))(1)
End If
Next i
'screenupdating true again, calc to auto
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
long time no see. I am dealing with a little task, that somehow I cannot wrap my head around. I have a huge excel sheet (around 4000 rows) which is being split and sent out to people - they mark yellow or red cells from K column to T column in the specific row and send it back every week, until the range K to T in those 4000 rows that has "X" value (meaning sent out) are marked either yellow or red (received back or not received). The excel sheet has a unique value in column J (so I am using MATCH). So by using this column J, I am going through each line in Data (Master sheet) and checking if this is found in Input sheet (something that has been returned from users), if it is found I go and copy the color of their marking to the original Data sheet. This works great as a charm for those yellow and red colors, the sub itself runs fast - just wondering if there are no errors (last time I did some macros were 3 years ago).
The problem - if the cell is empty, it is being pasted as WHITE back to the Data sheet and the original grid of the excel is gone (hard to read). Can anyone point me into the right direction? Thank you!
Sub test4()
Application.ScreenUpdating = False
Set dat = Sheets("Data")
n = dat.Range("J" & Rows.Count).End(xlUp).Row
Dim test As Long
For i = 2 To n
inputrow = 0
On Error Resume Next
inputrow = Application.WorksheetFunction.Match(Worksheets("Data").Range("J" & i).Value, Sheets("Input").Range("J:J"), 0)
On Error GoTo 0
If inputrow > 0 Then
o = dat.Range("A" & Rows.Count).End(xlUp).Row + 1
dat.Range("K" & i).Interior.Color = Sheets("Input").Range("K" & inputrow).DisplayFormat.Interior.Color
dat.Range("L" & i).Interior.Color = Sheets("Input").Range("L" & inputrow).DisplayFormat.Interior.Color
dat.Range("M" & i).Interior.Color = Sheets("Input").Range("M" & inputrow).DisplayFormat.Interior.Color
dat.Range("N" & i).Interior.Color = Sheets("Input").Range("N" & inputrow).DisplayFormat.Interior.Color
dat.Range("O" & i).Interior.Color = Sheets("Input").Range("O" & inputrow).DisplayFormat.Interior.Color
dat.Range("P" & i).Interior.Color = Sheets("Input").Range("P" & inputrow).DisplayFormat.Interior.Color
dat.Range("Q" & i).Interior.Color = Sheets("Input").Range("Q" & inputrow).DisplayFormat.Interior.Color
dat.Range("R" & i).Interior.Color = Sheets("Input").Range("R" & inputrow).DisplayFormat.Interior.Color
dat.Range("S" & i).Interior.Color = Sheets("Input").Range("S" & inputrow).DisplayFormat.Interior.Color
dat.Range("T" & i).Interior.Color = Sheets("Input").Range("T" & inputrow).DisplayFormat.Interior.Color
End If
Next i
End Sub
DisplayFormat.Interior.ColorIndex = xlNone will be True if the cell has not been colored. Unless you're working with Conditional Formatting you don't need the DisplayFormat
Sub test4()
Dim test As Long, inputrow, dat As Worksheet, wsInput As Worksheet
Dim n As Long, i As Long, c As Long, o
Application.ScreenUpdating = False
Set wsInput = Sheets("Input")
Set dat = Sheets("Data")
n = dat.Range("J" & Rows.Count).End(xlUp).Row
For i = 2 To n
inputrow = Application.Match(dat.Range("J" & i).Value, wsInput.Range("J:J"), 0)
If Not IsError(inputrow) Then 'check for match
o = dat.Range("A" & Rows.Count).End(xlUp).Row + 1
'loop over columns
For c = 11 To 20
With wsInput.Rows(inputrow).Cells(c)
'copy color if cell is not default color
If .Interior.ColorIndex <> xlNone Then
dat.Cells(i, c).Interior.Color = .Interior.Color
End If
End With
Next c
End If 'got match
Next i
End Sub
I've been asked to create a macro that compare two numbers in two cells and then it should write a third column that says for example: L6 is less than M6 (any image of a down arrow)
I tried to record this macro:
Sub Macro20()
Range("N2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-2]=RC[-1],""L and M are equal"",IF(RC[-2]>RC[-1],""L is greater than M (UP ARROW) "",""L is less than M (DOWN ARROW)""))"
Range("N2").Select
Selection.AutoFill Destination:=Range("N2:N" & Range("L" & Rows.Count).End(xlUp).Row)
Range(Selection, Selection.End(xlDown)).Select
End Sub
and this is the output:
This is just an example, the whole code should be used to a large amount of data soon, anyway there are some errors must be avoided.
The code into the cell must not be shown (see the blue arrow into the picture), it should display only the value.
How can I fetch an arrow image instead of the string: L is greater than M (UP ARROW)?
Can you help me in doing a better code than this?
Here is a simple solution which enters the formula in the entire range without looping.
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Find last row in column L
lRow = .Range("L" & .Rows.Count).End(xlUp).Row
'~~> Insert the formula in Col N. Change as applicable
With .Range("N1:N" & lRow)
.Formula = "=IF(L1=M1,""L and M are equal"",IF(L1>M1,""L is greater than M " & _
ChrW(&H2191) & _
""", ""L is less than M " & _
ChrW(&H2193) & _
"""))"
'~~> Optional - Convert formula to values
.Value = .Value
End With
End With
End Sub
Screenshot
Note:
To insert Up arrow, you can use ChrW(&H2191) and for down arrow you can use ChrW(&H2193)
If you want to put the formula from the 2nd row then it will be
'~~> Insert the formula in Col N. Change as applicable
With .Range("N2:N" & lRow)
.Formula = "=IF(L2=M2,""L and M are equal"",IF(L2>M2,""L is greater than M " & _
ChrW(&H2191) & _
""", ""L is less than M " & _
ChrW(&H2193) & _
"""))"
'~~> Optional - Convert formula to values
.Value = .Value
End With
Similarly for a different row, you will have to adjust accordingly.
EDIT
do you think is possible to use a arrow text already formatted? For example a red one (or whatever color) with a specific size? And then put this inside your vba code? – Alex D. 4 hours ago
Yes it is possible. In this case you can use Worksheet_Change event to handle changes in column L and column M to populate column N
I have commented the code below. If you still have problems understanding it then feel free to ask. The below code goes in the sheet code area. You can change the symbol attributes (Style, Color and Size) right at the top of the code.
Code
Option Explicit
'~~> Change the symbol attributes here
Const Font_Style As String = "Bold"
Const Font_Size As Long = 15
Const Font_Color As Long = -16776961 '(Red)
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
Application.EnableEvents = False
Dim r As Variant
'~~> Check if the change happened in the relevant column
If Not Intersect(Target, Me.Range("L:M")) Is Nothing Then
For Each r In Target.Rows
'~~> If even one cell is empty then clear out N cell
If Len(Trim(Range("L" & r.Row).Value2)) = 0 Or _
Len(Trim(Range("M" & r.Row).Value2)) = 0 Then
Range("N" & r.Row).ClearContents
'~~> Check if L = M
ElseIf Range("L" & r.Row) = Range("M" & r.Row) Then
Range("N" & r.Row).Value = "L and M are equal"
'~~> Check if L > M
ElseIf Range("L" & r.Row) > Range("M" & r.Row) Then
With Range("N" & r.Row)
.Value = "L is greater than M " & ChrW(&H2191)
'~~> Format the symbol which is at 21st position
With .Characters(Start:=21, Length:=1).Font
.FontStyle = Font_Style
.Size = Font_Size
.Color = Font_Color
End With
End With
'~~> L < M
Else
With Range("N" & r.Row)
.Value = "L is less than M " & ChrW(&H2193)
'~~> Format the symbol which is at 18th position
With .Characters(Start:=18, Length:=1).Font
.FontStyle = Font_Style
.Size = Font_Size
.Color = Font_Color
End With
End With
End If
Next r
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
In action
Here is an alternative:
Sub alex()
Dim i As Long, LastRow As Long
Dim L, M, txt As String
LastRow = Cells(Rows.Count, "L").End(xlUp).Row
For i = 2 To LastRow
L = Cells(i, "L").Value
M = Cells(i, "M").Value
If L = M Then
txt = "they are equal"
ElseIf L > M Then
txt = "L is greater"
Else
txt = "M is greater"
End If
Cells(i, "N") = txt
Next i
End Sub
You can speed this up a little by bring all the column L and M data into VBA arrays and doing the comparisons within VBA.
To get arrows rather than text, use:
Sub alex()
Dim i As Long, LastRow As Long
Dim L, M, txt As String
LastRow = Cells(Rows.Count, "L").End(xlUp).Row
For i = 2 To LastRow
L = Cells(i, "L").Value
M = Cells(i, "M").Value
If L = M Then
txt = "n"
ElseIf L > M Then
txt = "h"
Else
txt = "i"
End If
Cells(i, "N") = txt
Next i
End Sub
and format the results cells in column N to use the Wingdings 3 font
I want to create a userform that can find the "Sales" value in column E and then input the remaining data to the same row.
Set APAC = Sheet2
APAC.Activate
Range("E18:E1888").Select
For Each D In Selection
If D.Value = "TWO.Sales.Value" Then
Exit For
End If
Next D
Rows(D.Row).Select
D.Offset(0, 2).Value = TWO.RSA.Value
D.Offset(0, 3).Value = TWO.Part.Value
D.Offset(0, 4).Value = Application.WorksheetFunction.VLookup(TWO.Part.Value, Worksheets("DataEntry").Range("T2:U70").Value, 2, False)
D.Offset(0, 5).Value = TWO.Program.Value
D.Offset(0, 6).Value = TWO.QTY.Value
Sheet2.Activate
This is my code but
run time error '91'
occurs.
I am having error on the "Rows(D.Row).select" line – Jacob 2 mins ago
That means "TWO.Sales.Value" was not found in Range("E18:E1888") and hence D was nothing. You need to check if the value was found. Also I have a feeling that you wanted If D.Value = TWO.Sales.Value Then instead of If D.Value = "TWO.Sales.Value" Then
Also there is no need to Select/Activate. You can directly work with the objects. You may want to see How to avoid using Select in Excel VBA
Whenever you are working with VLookup, it is better to handle the error that may pop up when a match is not found. There are various ways to do it. I have shown one way in the code below.
Is this what you are trying? (UNTESTED)
Option Explicit
Sub Sample()
Dim APAC As Worksheet
Dim curRow As Long
Dim aCell As Range
Dim Ret
Set APAC = Sheet2
With APAC
For Each aCell In .Range("E18:E1888")
If aCell.Value = TWO.Sales.Value Then
curRow = aCell.Row
Exit For
End If
Next aCell
If curRow = 0 Then
MsgBox "Not Found"
Else
.Range("G" & curRow).Value = TWO.RSA.Value
.Range("H" & curRow).Value = TWO.Part.Value
On Error Resume Next
Ret = Application.WorksheetFunction.VLookup(TWO.Part.Value, _
Worksheets("DataEntry").Range("T2:U70").Value, 2, False)
On Error GoTo 0
If Ret <> "" Then .Range("I" & curRow).Value = Ret
.Range("J" & curRow).Value = TWO.Program.Value
.Range("K" & curRow).Value = TWO.QTY.Value
End If
End With
End Sub
NOTE: If the range .Range("E18:E1888") is dynamic then you may want to find the last row as shown HERE and then use the range as .Range("E18:E" & LastRow)
the code below works 100%. It scans for a match in Column B and copies and renames a group of cells when a match is found. However the is a line For lRow = Sheets("HR-Calc").Cells(Cells.Rows.count, "b").End(xlUp).Row To 7 Step -1
Where the step -1 will scan row by row from the bottom of the sheet until a match is found. It would be much easier if the step was set to End.(xlUp) instead of -1. searching every row is overkill because of how the data is set up End.(xlUp) would massive cut down the run time.
Is something like this possible?
Sub Fill_CB_Calc()
M_Start:
Application.ScreenUpdating = True
Sheets("summary").Activate
d_input = Application.InputBox("select first cell in data column", "Column Data Check", Default:="", Type:=8).Address(ReferenceStyle:=xlA1, RowAbsolute:=True, ColumnAbsolute:=False)
data_col = Left(d_input, InStr(2, d_input, "$") - 1)
data_row = Right(d_input, Len(d_input) - InStr(2, d_input, "$"))
Application.ScreenUpdating = False
Sheets("summary").Activate
Range(d_input).End(xlDown).Select
data_last = ActiveCell.Row
If IsEmpty(Range(data_col & data_row + 1)) = True Then
data_last = data_row
Else
End If
For j = data_row To data_last
CBtype = Sheets("summary").Range(data_col & j)
Sheets("HR-Calc").Activate
For lRow = Sheets("HR-Calc").Cells(Cells.Rows.count, "b").End(xlUp).Row To 7 Step -1
If Sheets("HR-Calc").Cells(lRow, "b") = CBtype Then
CBend = Sheets("HR-Calc").Range("C" & lRow).End(xlDown).Row + 1
Sheets("HR-Calc").Rows(lRow & ":" & CBend).Copy
CBstart = Sheets("HR-Calc").Range("c50000").End(xlUp).Row + 2
ActiveWindow.ScrollRow = CBstart - 8
Sheets("HR-Calc").Range("A" & CBstart).Insert Shift:=xlDown
CBold = Right(Range("c" & CBstart), Len(Range("C" & CBstart)) - 2)
box_name = Sheets("summary").Range(data_col & j).Offset(0, -10)
CBnew = Right(box_name, Len(box_name) - 2) & "-" ' <--this is custom and can be changed based on CB naming structure
If CBnew = "" Or vbCancel Then
End If
CBend2 = Range("c50000").End(xlUp).Row - 2
Range("C" & CBstart + 1 & ":" & "C" & CBend2).Select
Selection.Replace What:=CBold & "-", Replacement:=CBnew, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("C" & CBstart).FormulaR1C1 = "CB" & Left(CBnew, Len(CBnew) - 1)
GoTo M_Start2
Else
End If
Next lRow
M_Start2:
Next j
YN_result = MsgBox("Fill info for another block/inverter?", vbYesNo + vbExclamation)
If YN_result = vbYes Then GoTo M_Start
If YN_result = vbNo Then GoTo jumpout
jumpout:
' Sheets("summary").Range(d_input).Select
Application.ScreenUpdating = True
End Sub
I'm not sure if this will help but I've had a great performance increase with pulling the entire range you need to loop through into a variant array and then looping through the array. If I need to loop through large data sets, this method has worked out well.
Dim varArray as Variant
varArray = Range(....) 'set varArray to the range you're looping through
For y = 1 to uBound(varArray,1) 'loops through rows of the array
'code for each row here
'to loop through individual columns in that row, throw in another loop
For x = 1 to uBound(varArray, 2) 'loop through columns of array
'code here
Next x
Next y
You can also define the column indexes prior to executing the loop. Then you only need to execute the you need to pull those directly in the loop.
'prior to executing the loop, define the column index of what you need to look at
Dim colRevenue as Integer
colRevenue = 5 'or a find function that searches for a header named "Revenue"
Dim varArray as Variant
varArray = Range(....) 'set varArray to the range you're looping through
For y = 1 to uBound(varArray,1) 'loops through rows of the array
tmpRevenue = CDbl(varArray(y, colRevenue))
Next y
Hope this helps.
Look at doing a .find from the bottom up.
Perform a FIND, within vba, from the bottom of a range up
That will eliminate the need to do the for loop from the last row to the first occurrence of the value you want to locate.