Hi I am Trying to add to cells together and compare them against another cell but I get a type mismatch.
first cell is a date, the one being added is a number"as in number of days" and the third one being compared is a date also.
but I get type mismatch.
my code is below
Sub Macro1()
Macro1 Macro
Dim wks As Worksheet
Set wks = ActiveSheet
Dim x As Integer
Dim p As Integer
Dim rowRange As Range
Dim colRange As Range
Dim LastCol As Long
Dim LastRow As Long
LastRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
Set rowRange = wks.Range("A1:A" & LastRow)
For i = 7 To 189
p = 0
For q = 8 To LastRow
If [aq] = [si] Then
If [cq] + [ui] >= [xi] Then
[oq] = 1
Else
p = p + [dq]
[qq] = 0
End If
End If
Next q
Next i
End Sub
[cq] is a cell that contains date
[ui] is a cell that contains number
[xi] is a cell that contains date
Try it as cells(q, "A") = cells(i, "S").
For i = 7 To 189
p = 0
For q = 8 To LastRow
'If [aq] = [si] Then
If cells(q, "A") = cells(i, "S") Then
'If [cq] + [ui] >= [xi] Then
If cells(q, "C") + cells(i, "U") >= cells(i, "X") Then
'[oq] = 1
cells(q, "O") = 1
Else
'p = p + [dq]
p = p + cells(q, "D")
'[qq] = 0
cells(q, "Q") = 0
End If
End If
Next q
Next i
You need to use the "DateAdd" function. Instructions here: https://www.techonthenet.com/excel/formulas/dateadd.php
Example:
Sub add_dates()
Dim dateOne As Date
Dim dateTwo As Date
Dim lngDays As Long
dateOne = "1/1/2018"
lngDays = 2
dateTwo = "1/3/2018"
Dim result As Boolean
If DateAdd("d", lngDays, dateOne) >= dateTwo Then
MsgBox ("Greater than or equal to")
Else
MsgBox ("Less than")
End If
End Sub
I am writing a VBA code on excel using loops to go through 10000+ lines.
Here is an example of the table
And here is the code I wrote :
Sub Find_Matches()
Dim wb As Workbook
Dim xrow As Long
Set wb = ActiveWorkbook
wb.Worksheets("Data").Activate
tCnt = Sheets("Data").UsedRange.Rows.Count
Dim e, f, a, j, h As Range
xrow = 2
Application.ScreenUpdating = False
Application.Calculation = xlManual
For xrow = 2 To tCnt Step 1
Set e = Range("E" & xrow)
Set f = e.Offset(0, 1)
Set a = e.Offset(0, -4)
Set j = e.Offset(0, 5)
Set h = e.Offset(0, 3)
For Each Cell In Range("E2:E" & tCnt)
If Cell.Value = e.Value Then
If Cell.Offset(0, 1).Value = f.Value Then
If Cell.Offset(0, -4).Value = a.Value Then
If Cell.Offset(0, 5).Value = j.Value Then
If Cell.Offset(0, 3).Value = h.Value Then
If (e.Offset(0, 7).Value) + (Cell.Offset(0, 7).Value) = 0 Then
Cell.EntireRow.Interior.Color = vbYellow
e.EntireRow.Interior.Color = vbYellow
End If
End If
End If
End If
End If
End If
Next
Next
End Sub
As you can imagine, this is taking a lot of time to go through 10000+ lines and I would like to find a faster solution. There must be a method I don't think to avoid the over looping
Here are the condition :
For each line, if another line anywhere in the file has the exact same
:
Buyer ID (col. E)
`# purchased (col. F)
Product ID (col.A)
Payment (col. J)
Date purchased (col. H)
Then, if the SUM of the Amount (col. L) the those two matching line is
0, then color both rows in yellow.
Note that extra columns are present and not being compared (eg- col. B) but are still important for the document and cannot be deleted to ease the process.
Running the previous code, in my example, row 2 & 5 get highlighted :
This is using nested dictionaries and arrays to check all conditions
Timer with my test data: Rows: 100,001; Dupes: 70,000 - Time: 14.217 sec
Option Explicit
Public Sub FindMatches()
Const E = 5, F = 6, A = 1, J = 10, H = 8, L = 12
Dim ur As Range, x As Variant, ub As Long, d As Object, found As Object
Set ur = ThisWorkbook.Worksheets("Data").UsedRange
x = ur
Set d = CreateObject("Scripting.Dictionary")
Set found = CreateObject("Scripting.Dictionary")
Dim r As Long, rId As String, itm As Variant, dupeRows As Object
For r = ur.Row To ur.Rows.Count
rId = x(r, E) & x(r, F) & x(r, A) & x(r, J) & x(r, H)
If Not d.Exists(rId) Then
Set dupeRows = CreateObject("Scripting.Dictionary")
dupeRows(r) = 0
Set d(rId) = dupeRows
Else
For Each itm In d(rId)
If x(r, L) + x(itm, L) = 0 Then
found(r) = 0
found(itm) = 0
End If
Next
End If
Next
Application.ScreenUpdating = False
For Each itm In found
ur.Range("A" & itm).EntireRow.Interior.Color = vbYellow
Next
Application.ScreenUpdating = True
End Sub
Before
After
I suggest a different approach altogether: add a temporary column to your data that contains a concatenation of each cell in the row. This way, you have:
A|B|C|D|E
1|Mr. Smith|500|A|1Mr. Smith500A
Then use Excel's conditional formatting on the temporary column, highlighting duplicate values. There you have your duplicated rows. Now it's only a matter of using a filter to check which ones have amounts equal to zero.
You can use the CONCATENATE function; it requires you to specify each cell separately and you can't use a range, but in your case (comparing only some of the columns) it seems like a good fit.
Maciej's answer is easy to implement (if you can add columns to your data without interrupting anything), and I would recommend it if possible.
However, for the sake of answering your question, I will contribute a VBA solution as well. I tested it on dataset that is a bit smaller than yours, but I think it will work for you. Note that you might have to tweak it a little (which row you start on, table name, etc) to fit your workbook.
Most notably, the segment commented with "Helper column" is something you most likely will have to adjust - currently, it compares every cell between A and H for the current row, which is something you may or may not want.
I've tried to include a little commentary in the code, but it's not much. The primary change is that I'm using in-memory processing of an array rather than iterating over a worksheet range (which for larger datasets should be exponentially faster).
Option Base 1
Option Explicit
' Uses ref Microsoft Scripting Runtime
Sub Find_Matches()
Dim wb As Workbook, ws As Worksheet
Dim xrow As Long, tCnt As Long
Dim e As Range, f As Range, a As Range, j As Range, h As Range
Dim sheetArr() As Variant, arr() As Variant
Dim colorTheseYellow As New Dictionary, colorResults() As String, dictItem As Variant
Dim arrSize As Long, i As Long, k As Long
Dim c As Variant
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Data")
ws.Activate
tCnt = ws.UsedRange.Rows.Count
xrow = 2
Application.ScreenUpdating = False
Application.Calculation = xlManual
' Read range into an array so we process in-memory
sheetArr = ws.Range("A2:H" & tCnt)
arrSize = UBound(sheetArr, 1)
' Build new arr with "helper column"
ReDim arr(1 To arrSize, 1 To 9)
For i = 1 To arrSize
For k = 1 To 8
arr(i, k) = sheetArr(i, k)
arr(i, 9) = CStr(arr(i, 9)) & CStr(arr(i, k)) ' "Helper column"
Next k
Next i
' Iterate over array & build collection to indicate yellow lines
For i = LBound(arr, 1) To UBound(arr, 1)
If Not colorTheseYellow.Exists(i) Then colorResults = Split(ReturnLines(arr(i, 9), arr), ";")
For Each c In colorResults
If Not colorTheseYellow.Exists(CLng(c)) Then colorTheseYellow.Add CLng(c), CLng(c)
Next c
Next i
' Enact row colors
For Each dictItem In colorTheseYellow
'Debug.Print "dict: "; dictItem
If dictItem <> 0 Then ws.ListObjects(1).ListRows(CLng(dictItem)).Range.Interior.Color = vbYellow
Next dictItem
End Sub
Function ReturnLines(ByVal s As String, ByRef arr() As Variant) As String
' Returns a "Index;Index" string indicating the index/indices where the second, third, etc. instance(s) of s was found
' Returns "0;0" if 1 or fewer matches
Dim i As Long
Dim j As Long
Dim tmp As String
ReturnLines = 0
j = 0
tmp = "0"
'Debug.Print "arg: " & s
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, 9) = s Then
j = j + 1
'Debug.Print "arr: " & arr(i, 9)
'Debug.Print "ReturnLine: " & i
tmp = tmp & ";" & CStr(i)
End If
Next i
'If Left(tmp, 1) = ";" Then tmp = Mid(tmp, 2, Len(tmp) - 1)
'Debug.Print "tmp: " & tmp
If j >= 2 Then
ReturnLines = tmp
Else
ReturnLines = "0;0"
End If
End Function
On my simple dataset, it yields this result (marked excellently with freehand-drawn color indicators):
Thanks everybody for your answers,
Paul Bica's solution actually worked and I am using a version of this code now.
But, just to animate the debate, I think I also found another way around my first code, inspired by Maciej's idea of concatenating the cells and using CStr to compare the values and, of course Vegard's in-memory processing by using arrays instead of going through the workbook :
Sub Find_MatchesStr()
Dim AmountArr(300) As Variant
Dim rowArr(300) As Variant
Dim ws As Worksheet
Dim wb As Workbook
Set ws = ThisWorkbook.Sheets("Data")
ws.Activate
Range("A1").Select
rCnt = ws.Cells.SpecialCells(xlCellTypeLastCell).Row
For i = 2 To rCnt
If i = rCnt Then
Exit For
Else
intCnt = 0
strA = ws.Cells(i, 1).Value
strE = ws.Cells(i, 5).Value
strF = ws.Cells(i, 6).Value
strH = ws.Cells(i, 8).Value
strL = ws.Cells(i, 10).Value
For j = i To rCnt - 1
strSearchA = ws.Cells(j, 1).Value
strSearchE = ws.Cells(j, 5).Value
strSearchF = ws.Cells(j, 6).Value
strSearchH = ws.Cells(j, 8).Value
strSearchL = ws.Cells(j, 10).Value
If CStr(strE) = CStr(strSearchE) And CStr(strA) = CStr(strSearchA) And CStr(strF) = CStr(strSearchF) And CStr(strH) = CStr(strSearchH) And CStr(strL) = CStr(strSearchL) Then
AmountArr(k) = ws.Cells(j, 12).Value
rowArr(k) = j
intCnt = intCnt + 1
k = k + 1
Else
Exit For
End If
Next
strSum = 0
For s = 0 To UBound(AmountArr)
If AmountArr(s) <> "" Then
strSum = strSum + AmountArr(s)
Else
Exit For
End If
Next
strAppenRow = ""
For b = 0 To UBound(rowArr)
If rowArr(b) <> "" Then
strAppenRow = strAppenRow & "" & rowArr(b) & "," & AmountArr(b) & ","
Else
Exit For
End If
Next
If intCnt = 1 Then
Else
If strSum = 0 Then
For rn = 0 To UBound(rowArr)
If rowArr(rn) <> "" Then
Let rRange = rowArr(rn) & ":" & rowArr(rn)
Rows(rRange).Select
Selection.Interior.Color = vbYellow
Else
Exit For
End If
Next
Else
strvar = ""
strvar = Split(strAppenRow, ",")
For ik = 1 To UBound(strvar)
If strvar(ik) <> "" Then
strVal = CDbl(strvar(ik))
For ik1 = ik To UBound(strvar)
If strvar(ik1) <> "" Then
strVal1 = CDbl(strvar(ik1))
If strVal1 + strVal = 0 Then
Let sRange1 = strvar(ik - 1) & ":" & strvar(ik - 1)
Rows(sRange1).Select
Selection.Interior.Color = vbYellow
Let sRange = strvar(ik1 - 1) & ":" & strvar(ik1 - 1)
Rows(sRange).Select
Selection.Interior.Color = vbYellow
End If
Else
Exit For
End If
ik1 = ik1 + 1
Next
Else
Exit For
End If
ik = ik + 1
Next
End If
End If
i = i + (intCnt - 1)
k = 0
Erase AmountArr
Erase rowArr
End If
Next
Range("A1").Select
End Sub
I still have some mistakes (rows not higlighted when they should be), the above code is not perfect, but I thought it'd be OK to give you an idea of where I was going before Paul Bica's solution came in.
Thanks again !
If your data is only till column L, then use below code, I found it is taking less time to run....
Sub Duplicates()
Application.ScreenUpdating = False
Dim i As Long, lrow As Long
lrow = Cells(Rows.Count, 1).End(xlUp).Row
Range("O2") = "=A2&E2&F2&J2&L2"
Range("P2") = "=COUNTIF(O:O,O2)"
Range("O2:P" & lrow).FillDown
Range("O2:O" & lrow).Copy
Range("O2:O" & lrow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
For i = 1 To lrow
If Cells(i, 16) = 2 Then
Cells(i, 16).EntireRow.Interior.Color = vbYellow
End If
Next
Application.ScreenUpdating = True
Range("O:P").Delete
Range("A1").Select
MsgBox "Done"
End Sub
I have 2 excel sheets and i have to compare some values,this is the easy part. For this i used the following code :
Dim OldLabel() As String, size As Integer, i As Integer, j As Integer
size = WorksheetFunction.CountA(Worksheets(3).Columns(1))
ReDim OldLabel(size)
j = 1
For i = 7 To size
If (InStr(Cells(i, 1).Value, "[") > 0) Then
OldLabel(j) = Cells(i, 1).Value
j = j + 1
End If
Next i
Dim NewLabel() As String, newSize As Integer, k As Integer, l As Integer
newSize = WorksheetFunction.CountA(Worksheets(4).Columns(1))
ReDim NewLabel(newSize)
l = 1
For k = 7 To newSize
If (InStr(Cells(k, 1).Value, "[") > 0) Then
NewLabel(l) = Cells(k, 1).Value
l = l + 1
End If
Next k
After that i have to compare the values of the two arrays and check if they are the same and write them to another sheet. I have tried to following code but it doesn't seem to be working.
Dim cont As Integer
cont = 1
For i = 1 To size
For k = 1 To newSize
If (OldLabel(i) = NewLabel(k)) Then
Sheet8.Activate
Range("A1").Select
Cells(cont, 1).Value = OldLabel(i)
cont = cont + 1
End If
Next k
Next i
This is one of the cases I recommend the use of data collections instead of arrays:
'Define data collections:
Dim OldLabel As New Collection: Set OldLabel = New Collection
Dim NewLabel As New Collection: Set NewLabel = New Collection
'Define data limits:
Dim OldLimit As Integer
OldLimit = ThisWorkbook.Sheets("Sheet3").Columns(1).Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
Dim NewLimit As Integer
NewLimit = ThisWorkbook.Sheets("Sheet4").Columns(1).Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
'Define extra variables:
Dim counter As Integer
counter = 1
'Fill collections:
For x = 1 To OldLimit
If InStr(ThisWorkbook.Sheets("Sheet3").Cells(x, 1).text, "[") > 0 Then
OldLabel.Add ThisWorkbook.Sheets("Sheet3").Cells(x, 1).text
End If
Next x
For x = 1 To NewLimit
If InStr(ThisWorkbook.Sheets("Sheet4").Cells(x, 1).text, "[") > 0 Then
NewLabel.Add ThisWorkbook.Sheets("Sheet4").Cells(x, 1).text
End If
Next x
'Writer:
If OldLabel.Count > 0 And NewLabel.Count > 0 Then
For x = 1 To OldLabel.Count
For y = 1 To NewLabel.Count
If OldLabel(x) = NewLabel(y) Then
ThisWorkbook.Sheets("Sheet8").Cells(counter, 1).FormulaR1C1 = OldLabel(x)
counter = counter + 1
End If
Next y
Next x
End If
Please note: a) You don't have to activate worksheets for your procedure; b) I named the worksheets and used that name to reference them; for some reasons, I prefer don't use sheets indexes; c) Check the fact you're only comparing cells with the "[" character in them; d) If any of the data columns is empty, the code will produce an error.
it works good but he doesn't take the last line of the tab
can u please help me to find my errors !
Dim c As Range
Dim MaPlage As Range
For q = 2 To ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
Set MaPlage = Range("A:H, J:R").Rows(q)
For Each c In MaPlage.Cells
If Len(c.Value) = 0 Then c.Interior.Color = vbYellow
If CStr(ActiveSheet.Cells(q, 31).Value) = "Completed - Appointment made / Complété - Nomination faite" _
And WorksheetFunction.CountIf(MaPlage, "") = 0 Then
Select Case UCase(ActiveSheet.Cells(q, 14).Value)
Case "INA_CIN"
ActiveSheet.Cells(q, 42).Value = "XX"
End Select
End If
Next c
Next q
EDIT: updated to show how to highlight empty cells
Dim MaPlage As Range, c As Range
Set MaPlage = Sheet1.Range(Replace("A#:H#,J#:R#", "#", q))
For Each c In MaPlage.Cells '<<EDIT2 to remove extra space
If Len(c.Value) = 0 Then c.Interior.Color = vbRed
Next c
EDIT2:
Sub TT()
Const S As String = "Completed - Appointment made / Complété - Nomination faite"
Dim MaPlage As Range, c As Range, rw As Range
Dim q As Integer, blanks As Long
For q = 2 To ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
Set rw = Sheet1.Rows(q)
Set MaPlage = rw.Range("A1:H1,J1:R1")
blanks = 0
For Each c In MaPlage.Cells
If Len(c.Value) = 0 Then
c.Interior.Color = vbRed
blanks = blanks + 1
End If
Next c
If CStr(rw.Cells(31).Value) = S And blanks = 0 Then
Select Case UCase(rw.Cells(14).Value)
Case "INA_CIN"
rw.Cells(42).Value = "XX"
End Select
End If
Next q
End Sub
If the string is present in all 3 columns then the count should be 1 and should start looking for the string in the next row.
Private Sub Button()
inputData = Application.InputBox("Enter Application Name:", "Input Box Text", Type:=2)
I want a button to get the input string which I use for searching
Dim MyCount As Long
MyCount = 0
Dim rng1 As Range
Dim i As Integer
Dim c As Long
Dim rng As Range, cell As Range
Set rng = ActiveCell
I guess I have some error in the active cell. I guess it should be cell or something of that sort
ThisWorkbook.Activate
Set ws = Worksheets("extract")
With ws
i = 2
MyCount = 0
Here goes the loop
Do While i < 15506
c = 2
rng = Cells(i, c)
If Not InStr(rng, inputString) = True Then
c = 10
rng = Cells(i, c)
If Not InStr(rng, inputString) = True Then
c = 11
rng = Cells(i, c)
If Not InStr(rng, inputString) = True Then
i = i + 1
Else
MyCount = MyCount + 1
i = i + 1
End If
Else
MyCount = MyCount + 1
i = i + 1
End If
Else
MyCount = MyCount + 1
i = i + 1
End If
Loop
for displaying the number of rows
If Not rng1 Is Nothing Then
MsgBox inputData & "has matched and total count is:" & MyCount
Else
MsgBox inputData & " not found"
End If
End Sub
the total number of rows is: 15505. I'm very new to VB. please let me know if there are any new functions for this.
Not sure if I've understood correctly, but I think this may be what you are looking for:
Sub SO()
Dim cCount As Long, i As Long, inputString As String
inputString = InputBox("Enter Application Name:", "Input Box Text")
cCount = 0
For i = 2 To 15505
If InStr(Cells(i, 2).Value, inputString) > 0 And _
InStr(Cells(i, 10).Value, inputString) > 0 And _
InStr(Cells(i, 11).Value, inputString) > 0 Then cCount = cCount + 1
Next i
MsgBox "Number of matches is: " & cCount
End Sub