While executing the below script, I can't get rid of the run time error 9.
What I want to do is to search a specific cell value from sheet 2 and locate it in a range of cells in sheet 1.
Here is my script:
Public output() As Variant
Sub james()
Dim J As Object
Dim c As Object
Sheet2.Activate
ReDim ouput(3)
Set J = Cells(1, 1)
output(1) = J.Offset(0, 5).Value
output(2) = J.Offset(30, 5).Value
output(3) = J.Offset(60, 5).Value
Sheet1.Activate
Range("B7:B86").Select
For Each c In Selection
If c.Value = "output(1)" Then
Exit For
End If
Next c
Rows(c.Row).Select
End Sub
#SearchAndResQ is right, if you wanted your array to start at 1, you have two options:
Use Option Base 1 at the beginning of your module, or Redim output(1 to 3)
Also, you will want to change your If statement for:
If c.Value = output(1) then
All in all, this is a better version of your code:
Public output() As Variant
Sub james()
Dim J As Range
Dim c As Range
ReDim ouput(1 to 3)
Set J = Sheet2.Cells(1, 1)
output(1) = J.Offset(0, 5).Value
output(2) = J.Offset(30, 5).Value
output(3) = J.Offset(60, 5).Value
For Each c In Sheet1.Range("B7:B86")
If c.Value = output(1) Then
Exit For
End If
Next c
Rows(c.Row).Select
End Sub
Related
I am attempting to write some code that loops throw a column of data in one column ad matches it with data in another column all in the same sheet. When the two data points are matched the corresponding data will be copied to beside the first data point. The simplest way of putting it is I have a if statement inside a for Staten inside a while loop. I believe the issue is I am either not while looping correctly or I am not assigning the data correctly, either way the script is not writing any data to the columns they or supposed to write to. Any help in getting this script working would be appreciated see code below.
Sub s()
Dim i As Integer
Dim pointer As Integer
pointer = 1
Do While ThisWorkbook.Sheets("MPACSCodesedited").Cells(pointer, 13) <> ""
For i = 1 To 305
If ThisWorkbook.Sheets("MPACSCodesedited").Cells(i, 1).Value =
ThisWorkbook.Sheets("MPACSCodesedited").Cells(pointer, 13).Value Then
ThisWorkbook.Sheets("MPACSCodesedited").Cells(pointer, 14).Value = ThisWorkbook.Sheets("MPACSCodesedited").Cells(i, 2).Value
ThisWorkbook.Sheets("MPACSCodesedited").Cells(pointer, 15).Value = ThisWorkbook.Sheets("MPACSCodesedited").Cells(i, 3).Value
End If
pointer = pointer + 1
Next i
Loop
End Sub
Move pointer = pointer + 1 outside the For Loop
Sub s()
Dim i As Long
Dim pointer As Long
pointer = 1
Do While ThisWorkbook.Sheets("MPACSCodesedited").Cells(pointer, 13) <> ""
For i = 1 To 305
If ThisWorkbook.Sheets("MPACSCodesedited").Cells(i, 1).Value = ThisWorkbook.Sheets("MPACSCodesedited").Cells(pointer, 13).Value Then
ThisWorkbook.Sheets("MPACSCodesedited").Cells(pointer, 14).Value = ThisWorkbook.Sheets("MPACSCodesedited").Cells(i, 2).Value
ThisWorkbook.Sheets("MPACSCodesedited").Cells(pointer, 15).Value = ThisWorkbook.Sheets("MPACSCodesedited").Cells(i, 3).Value
End If
Next i
pointer = pointer + 1
Loop
End Sub
But as stated in my comments using variant arrays will be quicker:
Sub s()
With ThisWorkbook.Worksheets("MPACSCodesedited")
lastrw = .Cells(.Rows.Count, 13).End(xlUp).Row
Dim outarr As Variant
outarr = .Range(.Cells(1, 13), .Cells(.Cells(.Rows.Count, 13).End(xlUp).row,15)).Value
Dim SearchArr As Variant
SearchArr = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count,1).End(xlUp).Row, 3))
Dim i As Long
For i = LBound(outarr, 1) To UBound(outarr, 1)
Dim j As Long
For j = LBound(SearchArr, 1) To UBound(SearchArr, 1)
If SearchArr(j, 1) = outarr(i, 1) Then
outarr(i, 2) = SearchArr(j, 2)
outarr(i, 3) = SearchArr(j, 3)
Exit For
End If
Next j
Next i
.Range(.Cells(1, 13), .Cells(.Rows.Count, 14).End(xlUp)).Value = outarr
End With
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
Image1
Hi, Referring to the image, I am trying to compare column G and Column K, if the value is the same then copy the value in column J to column F. However, my code doesn't copy the value from Column J to F.
Sub createarray1()
Dim i As Integer
Dim j As Integer
Dim masterarray As Range
Set masterarray = Range("D3:G12")
Dim sourcearray As Range
Set sourcearray = Range("H3:K26")
For i = 1 To 10
For j = 1 To 25
If masterarray(i, 4).Value = sourcearray(j, 4).Value Then
masterarray(i, 3) = sourcearray(j, 3).Value
Else
masterarray(i, 3).Value = ""
End If
Next
Next
End Sub
Function concatenate()
Dim nlastrow As Long
For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
Cells(i, "G").Value = Cells(i, "D").Value & "_" & Cells(i, "E").Value
Next i
Dim nnlastrow As Long
For i = 2 To Cells(Rows.Count, "H").End(xlUp).Row
Cells(i, "K").Value = Cells(i, "H").Value & "_" & Cells(i, "I").Value
Next i
End Function
Use variant arrays, that way you limit the number of calls to the sheet to only 3.
When your positive is found you need to exit the inner loop.
Sub createarray1()
Dim i As Long
Dim j As Long
Dim masterarray As Variant
Dim sourcearray As Variant
With ThisWorkbook.Worksheets("Sheet1") ' change to your sheet
masterarray = .Range("D3:G12")
sourcearray = .Range("H3:K26")
For i = LBound(masterarray, 1) To UBound(masterarray, 1)
masterarray(i, 3) = ""
For j = LBound(sourcearray, 1) To UBound(sourcearray, 1)
If masterarray(i, 4) = sourcearray(j, 4) Then
masterarray(i, 3) = sourcearray(j, 3)
Exit For
End If
Next j
Next i
.Range("D3:G12") = masterarray
End With
End Sub
But this can all be done with the following formula:
=INDEX(J:J,MATCH(G3,K:K,0))
Put it in F3 and copy/drag down.
I'm writing a VBA program.
I have a problem with finding this string [BLOCKED] in one column
For j = 0 To 4
For i = 2 To lastrow
If Cells(i, 12).Value = groupnames(j) And Cells(i, 8).Value Like "*" & "[BLOCKED]" & "*" Then
groupsum(j) = groupsum(j) + 1
End If
Next i
Next j
The problem is I have 96 cells for this string but the program found 500 how can I do this to going work?
Thanks for help
The syntax of your Like operation is incorrect. Use:
... Like "*[[]BLOCKED]*"
[...] is a Character class. So, the way you have it written in your question, it will find any single character in the set of BLOCKED. That is not what you want, apparently.
To match the [ character, you enclose it within a character class, as I have shown. To match the ] character, it must be outside of a character class.
here is my code
Sub blocked()
Dim SfileUsers As String
Dim path As String
Dim pathread As String
Dim sFileread As String
Dim lastrow As Long
Dim keres() As Variant
Dim groupadd() As String
Dim groupnames(4) As String
Dim groupsum(4) As Long
path = "C:\Users\uids9282\Desktop\"
SfileUsers = "Users.xlsx"
Workbooks.Open path & SfileUsers
Dim hossz As Long
hossz = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
ReDim keres(hossz)
ReDim groupadd(hossz)
For i = 2 To hossz
keres(i) = Sheets(1).Cells(i, 2).Value
groupadd(i) = Sheets(1).Cells(i, 4).Value
Next i
'fájlmegnyitás
pathread = "C:\Users\uids9282\Desktop\20170703\"
sFileread = "open.xml"
If Dir(pathread & sFileread) = sFileread Then
Workbooks.Open pathread & sFileread
lastrow = Workbooks(sFileread).Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
Else
MsgBox ("Nincs ilyen nevű excel táblázat. Kérem próbálkozzon újra")
End If
'groupok hozzáadása a fájlhoz
Dim user As String
For j = 2 To hossz
For i = 2 To lastrow
user = Trim(Cells(i, 5).Value)
If user = keres(j) Then
Cells(i, 12).Value = groupadd(j)
End If
Next i
Next j
'group szummázása és átírása
ThisWorkbook.Activate
For i = 2 To 6
groupnames(i - 2) = Cells(i, 1).Value
Next i
Workbooks(sFileread).Activate
For j = 0 To 4
For i = 2 To lastrow
If Cells(i, 12).Value = groupnames(j) And Cells(i, 8).Value Like "*[[]BLOCKED[]]*" Then 'itt van benne a hiba!! groupsum(j) = groupsum(j) + 1
End If
Next i
Next j
ThisWorkbook.Activate
For j = 2 To 6
Cells(j, 4).Value = groupsum(j - 2)
Next j
Workbooks(SfileUsers).Close SaveChanges:=False
Workbooks(sFileread).Close SaveChanges:=True
End Sub
this is my excel file where i want to searching
I have two columns of numbers, together they will be unique (composite key). I would like to create an unique ID number (third column) similar to how MS Access would use a primary key. I would like to do this in VBA but I am stuck on how to do it.
My VBA in excel isn't very good so hopefully you can see what I've started to attempt. it may be completely wrong... I don't know?
I don't know how to make the next concatenation and I am unsure about how to go down to the next row correctly.
Sub test2()
Dim var As Integer
Dim concat As String
concat = Range("E2").Value & Range("F2").Value
var = 1
'make d2 activecell
Range("D2").Select
Do Until concat = ""
'if the concat is the same as the row before we give it the same number
If concat = concat Then
var = var
Else
var = var + 1
End If
ActiveCell.Value = var
ActiveCell.Offset(0, 1).Select
'make the new concatination of the next row?
Loop
End Sub
any help is appreciated, thanks.
Give the code below a try, I've added a loop which executes for each cell in the E Column. It checks if the concat value is the same as the concat value in the row above and then writes the id to the D cell.
Sub Test2()
Dim Part1 As Range
Dim strConcat As String
Dim i As Long
i = 1
With ThisWorkbook.Worksheets("NAME OF YOUR SHEET")
For Each Part1 In .Range(.Cells(2, 5), .Cells(2, 5).End(xlDown))
strConcat = Part1 & Part1.Offset(0, 1)
If strConcat = Part1.Offset(-1, 0) & Part1.Offset(-1, 1) Then
Part1.Offset(0, -1).Value = i
Else
i = i + 1
Part1.Offset(0, -1).Value = i
End If
Next Part1
End With
End Sub
Something like this should work, this will return a Unique GUID (Globally Unique Identifier):
Option Explicit
Sub Test()
Range("F2").Select
Do Until IsEmpty(ActiveCell)
If (ActiveCell.Value <> "") Then
ActiveCell.Offset(0, 1).Value = CreateGUID
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Public Function CreateGUID() As String
CreateGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
End Function
If you walk down column D and examine the concatenated values from column E and F with the previous row, you should be able to accomplish your 'primary key'.
Sub priKey()
Dim dcell As Range
With Worksheets("Sheet12")
For Each dcell In .Range(.Cells(2, 4), .Cells(Rows.Count, 5).End(xlUp).Offset(0, -1))
If LCase(Join(Array(dcell.Offset(0, 1).Value2, dcell.Offset(0, 2).Value2), ChrW(8203))) = _
LCase(Join(Array(dcell.Offset(-1, 1).Value2, dcell.Offset(-1, 2).Value2), ChrW(8203))) Then
dcell = dcell.Offset(-1, 0)
Else
dcell = Application.Max(.Range(.Cells(1, 4), dcell.Offset(-1, 0))) + 1
End If
Next dcell
End With
End Sub
You could use collections as well.
Sub UsingCollection()
Dim cUnique As Collection
Dim Rng As Range, LstRw As Long
Dim Cell As Range
Dim vNum As Variant, c As Range, y
LstRw = Cells(Rows.Count, "E").End(xlUp).Row
Set Rng = Range("E2:E" & LstRw)
Set cUnique = New Collection
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value & Cell.Offset(, 1), CStr(Cell.Value & Cell.Offset(, 1))
Next Cell
On Error GoTo 0
y = 1
For Each vNum In cUnique
For Each c In Rng.Cells
If c & c.Offset(, 1) = vNum Then
c.Offset(, -1) = y
End If
Next c
y = y + 1
Next vNum
End Sub