I am having a sheet having seven cloumns. First six columns having either true or false and in last column I have to mention the heading of false cases in one statement. Below is the excel.
Excel sheet
I have tried if else statement but there are too many possibilities. Since I am new to VBA i don't know any shortcut to that.Any suggestions?.... Thanks
Try this simple vba code,
Sub TEXTJOIN()
Dim i As Long, str As String, k As Long, j As Long
str = ""
j = 0
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Application.WorksheetFunction.CountIf(Range("A" & i & ":F" & i), True) = 6 Then
Cells(i, 7) = "No Discrepancy Found"
Else
For k = 1 To 6
If Cells(i, k) = False Then
str = str & Cells(1, k) & ","
j = j + 1
End If
Next k
str = Left(str, Len(str) - 1) & " mismatch found"
Cells(i, 7) = Application.WorksheetFunction.Substitute(str, ",", " and ", j - 1)
str = ""
j = 0
End If
Next i
End Sub
Here's simple code which you should try:
Sub FindDiscrepancies()
Dim lastRow, i, j As Long
Dim discrepancies As String: discrepancies = ""
'find number of last row
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
For j = 1 To 6
If LCase(Cells(i, j).Value) = "false" Then
discrepancies = discrepancies & Cells(1, j).Value & ", "
End If
Next j
If discrepancies = "" Then
Cells(i, 7).Value = "No discrepancies found"
Else
Cells(i, 7).Value = "Mismatch found in " & discrepancies
End If
discrepancies = ""
Next i
End Sub
Related
I was trying to create a script in vba which checks the cell "A1" and replaces the first 2 characters of the string with an integer. Should look something like this:
If (Left(A1, 2) = "NI") Then
newtext = Replace("originaltext", "NI", "801")
ElseIf (Left(A1, 2) = "RE") Then
newtext = Replace("originaltext", "RE", "821")
ElseIf (Left(A1, 2) = "NV") Then
newtext = Replace("originaltext", "NV", "571")
ElseIf (Left(A1, 2) = "NF") Then
newtext = Replace("originaltext", "NF", "831")
end if
n=n+1
Loop
I want it to go through every cell and do that action starting from a1 lets say all the way down to a2 and a3 and so on.
How do I create the right loop for that?
Consider:
Sub flay()
Dim i As Long, N As Long, v As Variant, frst As String
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
v = Cells(i, "A").Value
If Len(v) >= 2 Then
frst = Left(v, 2)
If frst = "RE" Then
Cells(i, "A").Value = Replace(v, "RE", "821")
ElseIf frst = "NI" Then
Cells(i, "A").Value = Replace(v, "NI", "801")
ElseIf frst = "NF" Then
Cells(i, "A").Value = Replace(v, "NF", "831")
ElseIf frst = "NV" Then
Cells(i, "A").Value = Replace(v, "NV", "571")
End If
End If
Next i
End Sub
Try the next code, please:
Sub testReplaceWithNumber()
Dim sh As Worksheet, lastR As Long, i As Long
Set sh = ActiveSheet 'use here the necessary sheet
lastR = sh.Range("A" & sh.Rows.count).End(xlUp).row
For i = 1 To lastR
Select Case left(sh.Range("A" & i).Value, 2)
Case "NI":
sh.Range("A" & i).Value = "801" & Mid(sh.Range("A" & i).Value, 3)
Case "RE":
sh.Range("A" & i).Value = "821" & Mid(sh.Range("A" & i).Value, 3)
Case "NV":
sh.Range("A" & i).Value = "571" & Mid(sh.Range("A" & i).Value, 3)
Case "NF":
sh.Range("A" & i).Value = "831" & Mid(sh.Range("A" & i).Value, 3)
End Select
Next i
End Sub
For each cl in
application.intersect(columns(1),activesheet.usedrange)
Select case left(cl,2)
Case "RE"
Mid(cl,1,2) ="821"
Case "NI"
Mid(cl,1,2) ="801"
' And so on
End select
Next
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 two sheets – Latency, TP. I need to copy col M from "Latency" and paste it into col D of "TP" only if "Latency" col E has the string “COMPATIBLE” and col O has the string “Pass”.
I have the below code, but it doesn't give any result.
I'm not sure whats wrong with it:
Sub sbMoveData()
Dim lRow As Integer, i As Integer, j As Integer
'Find last roe in Sheet1
With Worksheets("Latency")
lRow = .Cells.SpecialCells(xlLastCell).Row
j = 1
For i = 1 To lRow
If UCase(.Range("E" & i)) = "COMPATIBLE" And UCase(.Range("O" & i)) = "Pass" Then
.Range("M" & i).Copy Destination:=Worksheets("TP").Range("D" & j)
j = j + 1
End If
Next
End With
End Sub
UCase(.Range("O" & i)) = "Pass"
Will always be false :-)
You are never going to match UCase(Cell) = "Pass", right? You either need to have:
UCase(.Range("O" & i)) = "PASS"
or
.Range("O" & i) = "Pass"
Try this
Sub sbMoveData()
Dim lRow As Integer, i As Integer, j As Integer
Dim ws1, ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Latency")
Set ws2 = ThisWorkbook.Sheets("TP")
'Find last roe in Sheet1
lRow = ws1.Cells.SpecialCells(xlLastCell).Row
j = 1
For i = 1 To lRow
If ws1.Range("A" & i) = "COMPATIBLE" And ws1.Range("B" & i) = "Pass" Then
ws1.Range("M" & i).Copy Destination:=ws2.Range("D" & j)
j = j + 1
End If
Next i
End Sub
I am doing automation on matching Data form row Data1 to Data 2,
I was done by looping statement but the problem is take much time, when number of row increase
For that reason i planed do by vlookup, In vlookup only return first occurrence cell but i need to find all match cell and highlighted matched row ,which i show in figure.
Working with cells directly reduces the code performance. Try to set Data1 and Data2 to arrays and work with arrays.
Something like this:
With ActiveSheet
arr = .Range(.[A2], .Cells(.Rows.Count, "A").End(xlUp)).Value
arr2 = .Range(.[D2], .Cells(.Rows.Count, "D").End(xlUp)).Value
For i& = 1 To UBound(arr)
For j& = 1 To UBound(arr2)
If arr(i, 1) = arr2(j) Then
...
End If
Next j
Next i
End With
Hope you are looking for this
Sub testvlookup()
Dim lastrow, lastrowdata, incre, i, j As Long
lastrow = Range("A" & Rows.Count).End(xlUp).Row
lastrowdata = Range("D" & Rows.Count).End(xlUp).Row
incre = 6
For i = 2 To lastrow
For j = 2 To lastrowdata
If Range("A" & i).Value = Range("D" & j).Value Then
Range("D" & j, "G" & j).Interior.ColorIndex = incre
End If
Next j
incre = incre + 1
Next i
End Sub
I don't see the point why it should be to slow for many rows, it would be good to have more informations about that.
I would do it like the others, takes ~1 sec with 100000 comparisons.
Dim i As Integer
Dim b As Integer
i = 1
While i < 20000
Range("A1:A5").Copy Range(Cells(i, 4), Cells(i + 5, 4))
i = i + 5
Wend
MsgBox ("hi")
i = 1
While i < 7
b = 3
While b < 20000
If Cells(i, 1).Value = Cells(b, 4).Value Then
Cells(b, 4).Interior.ColorIndex = i
End If
b = b + 1
Wend
i = i + 1
Wend
End Sub
How do i add dashes(-) til my cell value = 5, If my length character is not equal to five and i have a 4 character, for ex A B... what i want it to do if i have cell value less then 5 then i want it to replace with dashes(-) till my cell length value reach to 5 character. Here is my Code and image... IMAGE will make more sense.. let me know if there is any confusion.
Sub xn()
Dim x As Integer, lastrow As Long, a As Long, i As Long
Dim xcell As String
a = 1
lastrow = Worksheets("Sheet2").UsedRange.Rows.Count + 1
For i = a To lastrow
xcell = Worksheets("Sheet2").Range("A" & i).Value
Do Until Len(xcell) = 5
If Len(xcell) <> 5 Then
Worksheets("Sheet2").Range("C" & i) = Replace(xcell, " ", "_")
Else
Exit Do
End If
Loop
Next i
End Sub
try this
Sub test()
Dim lastrow&, i&, xcell$, z%
lastrow = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To lastrow
xcell = Replace(Sheet2.Range("A" & i).Value, " ", "")
If Len(xcell) < 5 And xcell <> "" Then
z = 5 - Len(xcell)
Sheet2.Cells(i, "C").Value = Left(xcell, Len(xcell) - 1) & _
WorksheetFunction.Rept("-", z) & Right(xcell, 1)
Else
Sheet2.Cells(i, "C").Value = xcell
End If
Next i
End Sub
output
This line isn't going to do anything unless there's already spaces padding the end of the string:
Worksheets("Sheet2").Range("C" & i) = Replace(xcell, " ", "_")
You need to check the length, if it's less than five, add 5 - length characters to the end of it:
Sub xn()
Dim lastrow As Long
Dim i As Long
Dim xcell As String
lastrow = Worksheets("Sheet2").UsedRange.Rows.Count + 1
For i = 1 To lastrow
xcell = Worksheets("Sheet2").Range("A" & i).Value
If Len(xcell) < 5 Then
Worksheets("Sheet2").Range("C" & i) = xcell & String$(Len(xcell) - 5, "_")
End If
Next i
End Sub
You can also leave out the variable 'a' - it's basically a constant in the code you posted.