i am having troubles after fixing next variable issues. I am now getting run time errors 424. I believe this is because i am not naming my variables correctly as strings or Integers. I have two methods to the code and they are both resulting in the same error.
Columns 11 and 1 are text that need to match
Column 10 and columns(v) are dates that need to match
Column 2 will be text with a number at the end
Columns(V) will be a number with a number at the end
the logic of the loop makes sense to me but can't figure out what's causing the issue.
If cell.Value(J, 11) = Master.cell.Value(P, 1) And cell.Value(J, 10) = Master.cell.Value(P, V) Then
error Produced here "Run time '424' Object Required, What object am i missing? (error in bold)
Sub IndexInfo()
'
' Loops through data and finds matches and then indexs information
'
Dim J As Integer
Dim P As Integer
Dim V As Integer
Dim Master As Worksheet
Dim Gracie As Worksheet
IRowL = Cells(Rows.Count, 1).End(xlUp).Row
Set Master = Worksheets("Master")
Set Gracie = Worksheets("Gracie")
For J = 2 To IRowL
For V = 21 To 50
For P = 2 To IRowL
If Gracie.Cells(J, 11).Value = Master.Cells(P, 1).Value And Gracie.Cells.Value(J, 10) = Master.Cells(P, V).Values Then
Gracie.Cells(J, 30).Value = Master.Cells(P, 2).Value And Gracie.Cells(J, 31).Value = Master.Cells(1, V).Value
Else
End If
Next P
Next V
Next J
End Sub
Related
The script fills an array from a sheet called "Tigers" with 6 strings. Then it is supposed to compare that array to a differnt sheet titled "Elephants" and tell me if it finds an exact match. The troublesome code is found at the Application.Match method
Any help understanding how to correctly script a match with multiple values would be appreciated.
Sub matchData()
Dim arrCompare(5) As Variant
Dim intRow As Integer
Dim varRes As Variant
Set sht = ActiveSheet
Set shtTigers = Worksheets("Tigers").Range("A2:A100")
Set shtElephants = Worksheets("Elephants").Range("A2:A100")
Sheets("Elephants").Activate
For intRow = 2 To 100
arrCompare(0) = Worksheets("Elephants").Cells(intRow, 1).Value
arrCompare(1) = Worksheets("Elephants").Cells(intRow, 2).Value
arrCompare(2) = Worksheets("Elephants").Cells(intRow, 4).Value
arrCompare(3) = Worksheets("Elephants").Cells(intRow, 5).Value
arrCompare(4) = Worksheets("Elephants").Cells(intRow, 7).Value
arrCompare(5) = Worksheets("Elephants").Cells(intRow, 9).Value
'compare all 6 strings in array against Elephant sheet rows for a match
varRes = Application.Match(arrCompare(), shtTigers, 0)
'also tried
'varRes = Application.Match(((arrCompare(0))*((arrCompare(1))*((arrCompare(2)) * ((arrCompare(3)) * ((arrCompare(4)) * ((arrCompare(5))*((arrCompare(6)),shtTigers, 0)
'messagebox just gives a Error 13 or 2042 for varRes
MsgBox ("varRes = " & varRes)
Next
End Sub
Match requires a single lookup value but you're trying to pass the whole array. Iterate one element at at time instead:
Dim counter as Integer
For x = 0 to 5
If Not IsError(Application.Match(arrCompare(x), shtTigers, 0)) Then
counter = counter + 1
End If
Next x
If counter = 6 Then Debug.Print "Matches found"
This the code I am trying to run:
Option Explicit
Sub Test()
'-------------Declarations-------------------
Dim FinalRow, Sum As Long
Dim i, j, l, d, k, count As Integer
Dim custID(), amtPur() As Long
Dim ws As Worksheet
Set ws = Sheets("Data")
FinalRow = ws.Range("B90000").End(xlUp).Row
j = 0
'-------------Get All the Data-------------------
With ws
For i = 4 To FinalRow
custID(j) = ws.Range("B" & i).Value 'Error Here
amtPur(j) = ws.Range("C" & i).Value 'Error Here
j = j + 1
Next i
End With
'-------------Match it and present the output----
l = 4
Dim wk As Worksheet
Set wk = Sheets("Results")
With wk
For j = 0 To FinalRow
Sum = amtPur(j)
'For the first iteration
If j = 0 Then
For k = j + 1 To FinalRow
If custID(j) = custID(k) Then
Sum = amtPur(k) + Sum
Else: End If
Next k
wk.Range("A" & 3).Value = custID(j).Value
wk.Range("B" & 3).Value = Sum
Else: End If
'For the rest iterations
count = 0
d = j
Do While (d >= 0)
If custID(d) = custID(j) Then
count = count + 1
Else: End If
d = d - 1
Loop
If count <= 1 Then 'Check if instance was already found
For k = j + 1 To FinalRow
If custID(j) = custID(k) Then
Sum = amtPur(k) + Sum
Else: End If
Next k
wk.Range("A" & l).Value = custID(j).Text
wk.Range("B" & l).Value = Sum
l = l + 1
End If
Next j
End With
End Sub
but unfortunately am getting:
Subscript out of Range - Run time error 9
when I try to run it.
While you have declared your custID() and amtPur() arrays, they need to be initialised using ReDim statements before you can use them. In your case you will want to ReDim Preserve to retain values already stored in the arrays during prior loops:
Sub Test()
'-------------Declarations-------------------
Dim FinalRow, Sum As Long
Dim i As Integer
j As Integer
l As Integer
d As Integer
k As Integer
count As Integer
Dim custID() As Long, amtPur() As Long
Dim ws As Worksheet
Set ws = Sheets("Data")
FinalRow = ws.Range("B90000").End(xlUp).Row
j = 0
'-------------Get All the Data-------------------
With ws
For i = 4 To 100
ReDim Preserve custID(0 To j)
ReDim Preserve amtPur(0 To j)
custID(j) = ws.Range("B" & i).Value 'Error Here
amtPur(j) = ws.Range("C" & i).Value 'Error Here
j = j + 1
Next i
End With
End Sub
Hmm, seems a little harsh that this question has been downvoted. You're clearly new to VBA and it does seem that you've given this a fair go. I admire people who learn through trial and error - it's certainly more than many first posters do - so I'd like to give you a pretty full answer with a bit of the theory behind it:
Dim - as mentioned, declare each type. Avoid names that are similar to existing functions, like sum.
If you declare your 'read' variable as a variant, you can read the data from the worksheet with just one line and the array will be dimensioned for you. You can also acquire custID and amtPur in the same array. I've given you an example of this in the code below in a variable called custData. Be aware that these arrays have a base of 1 rather than 0.
Your With blocks are redundant. These are meant to save you repeating the object each time you access its properties. In your code you repeat the object. I'm not a huge fan of With blocks but I've put a sample in your code so you can see how it works.
Your If ... Else ... End If blocks are a bit muddled. The logic should be If (case is true) Then do some code Else case is false, so do some other code End If. Again, I've tried to re-write your code to give you examples of this.
You are confusing looping through a Range and looping through an Array. In your code you have set the limits of the Range as 4 - FinalRow. However, this does not mean your arrays have been set to the same dimensions. Most likely, your arrays start from 0 and go to FinalRow - 4. You need to be clear about these dimensions before looping.
As Mark Fitzgerald mentions, you need to dimension your array before using it. If it's an initial dimension then you could just use Redim. If you want to increase the array's dimension whilst retaining existing values then use Redim Preserve. I've tried to give you an example of both in the code below.
Okay, so onto your code...
With the looping, array size and If mistakes, it's rather difficult to see what you're trying to do. I think you might be trying to read all the customer IDs, writing them into a unique list and then summing all the values that match each ID. The code below does that. It's not the quickest or best way, but I've tried to write the code so that you can see how each of the errors above should work. I guess it doesn't matter if I'm up the wrong path as the main aim is to give you an idea of how to manage arrays, loops and Ifs. I hope your custID and amtPur are genuinely Longs - if, for example, amtPur stands for 'amount purchased' and is, in fact, a decimal number then this code will throw and error, so make sure your values and declarations are of the same type. Your commenting etiquette is a little esoteric but I've still followed it.
Good luck with your project and keep at it. I hope this helps you:
'-------------Declarations-------------------
Dim dataSht As Worksheet
Dim resultsSht As Worksheet
Dim custData As Variant
Dim uniqueIDs() As Long
Dim summaryData() As Long
Dim counter As Integer
Dim isUnique As Boolean
Dim rng As Range
Dim i As Integer
Dim j As Integer
'-------------Get All the Data-------------------
Set dataSht = ThisWorkbook.Sheets("Data")
Set resultsSht = ThisWorkbook.Sheets("Results")
With dataSht
Set rng = .Range(.Cells(4, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Resize(, 2)
End With
custData = rng.Value2 'writes worksheet to variant array
'-------------Loop through the data to find number of unique IDs----
For i = 1 To UBound(custData, 1)
isUnique = True
If i = 1 Then
'First iteration so set the counter
counter = 0
Else
'Subsequent iterations so check for duplicate ID
For j = 1 To counter
If uniqueIDs(j) = custData(i, 1) Then
isUnique = False
Exit For
End If
Next
End If
'Add the unique ID to our list
If isUnique Then
counter = counter + 1
ReDim Preserve uniqueIDs(1 To counter)
uniqueIDs(counter) = custData(i, 1)
End If
Next
'-------------Aggregate the amtPur values----
ReDim summaryData(1 To counter, 1 To 2)
For i = 1 To counter
summaryData(i, 1) = uniqueIDs(i)
'Loop through the data to sum the values for the customer ID
For j = 1 To UBound(custData, 1)
If custData(j, 1) = uniqueIDs(i) Then
summaryData(i, 2) = summaryData(i, 2) + custData(j, 2)
End If
Next
Next
'-----------Outpute the results to the worksheet----
Set rng = resultsSht.Cells(4, 1).Resize(counter, 2)
rng.Value = summaryData
Hi i'm a novice at vb (aka learned it today) and i wrote a code that's supposed to count how many identical serial numbers are in a list (listed in a column) and post each serial number with the number of times it's listed on another sheet.
When i run my code as is, nothing happens. No errors, nothing new on the sheet. I limited my list to 1-10 in my current code because when it was 1-10000 excel crashed. Can anyone give me pointers on what's happening?? Thank you!
Public Sub count()
Dim count As Long
Dim i, j, a As Integer
Dim skuNames() As Double
a = 2
count = 0
ReDim skuNames(1)
skuNames(0) = Worksheets("RawBarcodeData").Cells(1, 1).Value
'this checks if an sku matches an existing sku in the array and adds if it does not'
For i = 1 To 10
For j = 0 To UBound(skuNames)
If Worksheets("RawBarcodeData").Cells(i, 1).Value <> skuNames(j) And j <> UBound(skuNames) Then
ElseIf Worksheets("RawBarcodeData").Cells(i, 1).Value <> skuNames(j) And j = UBound(skuNames) Then
ReDim Preserve skuNames(0 To UBound(skuNames) + 1)
skuNames(UBound(skuNames)) = Worksheets("RawBarcodeData").Cells(i, 1).Value
Else
End If
Next j
Next i
'this will count how many of each element of the array is listed and post it'
For j = 0 To UBound(skuNames)
For i = 1 To 10
If skuNames(j) = Worksheets("RawBarcodeData").Cells(i, 1).Value And i <> 10000 Then
count = count + 1
ElseIf skuNames(j) = Worksheets("RawBarcodeData").Cells(i, 1).Value And i = 10000 Then
count = count + 1
Worksheets("InventoryReport").Cells(a, 1).Value = skuNames(j)
Worksheets("InventoryReport").Cells(a, 3).Value = count
a = a + 1
count = 0
ElseIf skuNames(j) <> Worksheets("RawBarcodeData").Cells(i, 1).Value And i <> 10000 Then
ElseIf skuNames(j) <> Worksheets("RawBarcodeData").Cells(i, 1).Value And i = 10000 Then
Worksheets("InventoryReport").Cells(a, 1).Value = skuNames(j)
Worksheets("InventoryReport").Cells(a, 3).Value = count
a = a + 1
count = 0
End If
Next i
Next j
End Sub
maybe your code didn't crash but just entered in a long loop.
the reasons are because you didn't use
application.screenupdating= false
application.enableevents=false
application.calculation=xlManual
at the begin of the code, and then set it to true, and xlautomatic at the end.
An other reason is you ask your code too often to read again the same cell value
(Worksheets("RawBarcodeData").Cells(i, 1).Value)
Why not tell your code to memorize it at the begin of loop ?
CellI1= Worksheets("RawBarcodeData").Cells(i, 1).Value ' for example
Also when you use i and j as integer, it's slower then as Long :
dim i as long, j as long.
An other thing , in your code i is a variant, not an integer as you might think
dim i , j as integer
translates as :
dim i 'vba by default sets it as variant
dim j as integer
You can make the code simpler with asking less long "if" lines, but use more if's.
use first the if wich will occur more often (if i<>1000)
so something like:
if i<1000 then
if CellI1=Skunames(j) then
'somethinf
else 'no need to ask if <> because it's already not =
'something
end if
else 'here i=1000, no need to test if
if CellI1=Skunames(j) then
'somethinf
else 'no need to ask if <> because it's already not =
'something
end if
end if
Other thing , use variables for worksheet:
dim Sh as Worksheet
set sh=Worksheets("RawBarcodeData")
and then sh.cells(i,1).value is as better way to write it.
Later on, you can even use the "With" statement.
with sh
a= .cells(i,j).value
if skullname(j) <> .cells(i,1).value
end with
this way excel doesn't need to recalculate/reread the sheet (or variable) at each pass.
And finally, an other way to find matches of same value in a range is to use the "match" function. (i don't recommend the "find" function wich is slower)
for very big ranges of data, you can use arrays, instead of looping through cells.values :
dim MyArray() as variant 'works only with variant
dim Max as Long
dim Sh as Worksheet
set Sh=thisworkbook.sheets("Test")
with sh
max = .cells( .rows.count,1).end(xlup).row 'return the last row in first column
MyArray = .range ( .cells(1,1) , .cells ( max,1) ).value 'fast way to memorize the whole range
'can also be written = . range ( "A1:A" & max).value ' but is slower
end with
and later on, instead of working with cell(i,1).value , you have the same value in MyArray (i,1) 'and no ".value" at the end this time
Don't forget to free some memory at the end with this code:
erase MyArray
set sh=nothing
have fun with VBA
line of code which transfers data to other sheet ,i.e. below lines:
Worksheets("InventoryReport").Cells(a, 1).Value = skuNames(j)
Worksheets("InventoryReport").Cells(a, 3).Value = count
will only execute when "i=10000", this criteria is not met when you run code, to debug how ur program is doing, run it in debug mode, step by step (press "F8" key to execute one line at a time)
I am looking to find out how I can remove ALL duplicate rows (when duplicates exist in the first column) using a VBA macro.
Currently Excel macros delete all duplicate instances EXCEPT for the first instance, which is totally not what I want. I want absolute removal.
A bit shorter solution done for quick morning training:
Sub quicker_Option()
Dim toDel(), i As Long
Dim RNG As Range, Cell As Long
Set RNG = Range("a1:a19") 'set your range here
For Cell = 1 To RNG.Cells.Count
If Application.CountIf(RNG, RNG(Cell)) > 1 Then
ReDim Preserve toDel(i)
toDel(i) = RNG(Cell).Address
i = i + 1
End If
Next
For i = UBound(toDel) To LBound(toDel) Step -1
Range(toDel(i)).EntireRow.Delete
Next i
End Sub
Store the first instance's cell for later deleting.
Then go deleting duplicates until the end.
Dim F as integer, S as integer 'indices for First and Second cells to be compared
Dim Deleted as boolean 'indicates if second line was deleted
Dim First as Range, Second as Range 'First and second cells to be compared
Dim Start as string 'Indicates the position of the first cell's start
Start = "A1" 'can be as you like
Set First = Sheet1.Range(Start) 'Sets the start cell
F = 0 '
Do While First.Value <> "" 'loop while sheet contains data in the column
S = F + 1 'second cell is at least 1 cell below first cell
Deleted = false 'no second cell was deleted yet
Set Second = First.Offset(S,0) 'second cell is an offset of the first cell
Do While Second.Value <> "" 'loop while second cell is in sheet's range with data
if Second.Value = First.Value then 'if values are duplicade
Second.EntreRow.Delete 'delete second cell
Deleted = true 'stores deleted information
else 'if not, second cell index goes next
S = S + 1;
end if
Set Second = First.Offset(S, 0) 'sets second cell again (if deleted, same position, if not deleted, next position
Loop
if Deleted then 'if deleted, should delete first cell as well
First.EntireRow.Delete
else
F = F + 1 'if no duplicates found, first cell goes next
end if
Set First = Sheet1.Range(Start).Offset(F,0) 'sets first cell again (if deleted, same position, if not, next)
Loop
I am using this code to create an Auto reconciliation of general ledger control accounts where if any cell with equal value but opposite sign is cut to sheet 2; hence left with only reconciliation item.
the code:
sub autoRecs()
dim i as long
Application.ScreenUpdating = False
Application.StatusBar = True
Dim i As Long
Cells(5, 6).Select
Dim x As Long
Dim y As Long
x = ActiveCell.Row
y = x + 1
Do Until Cells(x, 6) = 0
Do Until Cells(y, 6) = 0
Application.StatusBar = "Hey Relax! You can rely on me......"
If Cells(x, 6) = Cells(y, 6) * -1 Then
Cells(x, 6).EntireRow.Cut (Worksheets(2).Cells(x, 6).EntireRow)
Cells(y, 6).EntireRow.Cut (Worksheets(2).Cells(y, 6).EntireRow)
Cells(x, 6).Value = "=today()"
Cells(y, 6).Value = "=today()"
Else
y = y + 1
End If
Loop
x = x + 1
y = x + 1
Loop
Application.StatusBar = False
End Sub
Sub deleteBlankCells()`this is to delete unnecessary cells after run the above macro`
Range(Cells(5, 1), Cells(Rows.Count, 1).End(xlUp)).Select
For i = Selection.Rows.Count To 1 Step -1
Application.StatusBar = "OOH! I'm cleaning all the blanks for you....."
If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then
Selection.Rows(i).EntireRow.Delete
End If
Next i
Application.StatusBar = False
End Sub
I like to work with arrays within VBA, so here is an example.
Assume the data represents the currentregion around A1, but that is easily changed
Read the source data into an array
Check each item in column one to ensure it is unique (countif of that item = 1)
If unique, add the corresponding row number to a Collection
Use the size of th collection and the number of columns to Dim a results array.
Cycle through the collection, writing the corresponding rows to a results array.
Write the results array to the worksheet.
As written, the results are placed to the right of the source data, but could also replace it, or be placed on a different sheet.
Option Explicit
Sub RemoveDuplicatedRows()
Dim vSrc As Variant, vRes() As Variant
Dim rSrc As Range, rRes As Range
Dim colUniqueRows As Collection
Dim I As Long, J As Long
'assume data starts in A1 and represented by currentregion
Set rSrc = Range("a1").CurrentRegion
vSrc = rSrc
Set rRes = rSrc.Offset(0, UBound(vSrc, 2) + 2)
'get collection of non-duplicated rows
Set colUniqueRows = New Collection
For I = 1 To UBound(vSrc)
If WorksheetFunction.CountIf(rSrc.Columns(1), vSrc(I, 1)) = 1 Then _
colUniqueRows.Add I
Next I
'Make up results array
ReDim vRes(1 To colUniqueRows.Count, 1 To UBound(vSrc, 2))
For I = 1 To UBound(vRes, 1)
For J = 1 To UBound(vSrc, 2)
vRes(I, J) = vSrc(colUniqueRows(I), J)
Next J
Next I
rRes.EntireColumn.Clear
rRes.Resize(UBound(vRes)) = vRes
End Sub
I have a workbook that is organized within a main sheet. Every item has 3 rows. These items are grouped and sub-grouped by row and columns.
I have developed several reporting options. These reports identify certain items based upon characteristics in the main sheet and copy them over to another sheet. So far, so good.
My final task would appear simple and based upon prior logic I developed. I need a pop-up window that prompts the user for a column. Based upon the column input, I grab all rows that are not empty (in their corresponding groups of 3) and copy them over. As I indicated, this logic worked previously. I leave a blank row between the groups for easy reading.
I take the column input and translate to column number (thanks to you and a previous post!). The problem is that the code copies over the groups correctly (with non-blank entries), and then once it leaves the first row grouping, it starts copying over non-blank entries.
I know what the entries will be in these columns and also tried using a key method - converting the known entries to ascii and checking cell value against that. Still, the same result.
I am wondering if the problem is the fact that the code resides in the userform? Do I need to separate the userform from the macro? Is columnNumber somehow getting overwritten (it appears that way). There may be artifacts (unused variables) from previous versions and troublshooting...
I grant this is not the most elegant coding I've done, but I am running out of time (I only have a few days left for this entire project). Here it is, and ANY advice or help is greatly appreciated. THANK YOU well in advance :)
Private Sub Cancel_Click()
UserForm4.Hide
End Sub
Private Sub Go_Click()
Dim Test As String
Dim colNumber, columnNumber As Integer
Dim m As Integer
Dim ws2 As String
Dim i, j, k, r As Integer
Dim BlankRow2
Dim ColorCode As Integer
Dim RqtRow As Integer
Dim Item As Integer
Dim ColVal, AscCol As String
Dim Row1Value, Row2Value, Row3Value As Integer
' Initialize Variables
ws1 = "Requirements_Matrix"
ws2 = "OUTPUT"
RqtRow = 8
BlankRow2 = 4
Item = BlankRow2
Lastrow1 = Sheets(ws1).Cells(Rows.Count, "A").End(xlUp).Row
Lastcol1 = Sheets(ws1).Cells(1, Columns.Count).End(xlToLeft).Column
Lastrow2 = Sheets(ws2).Cells(Rows.Count, "A").End(xlUp).Row
Lastcol2 = Sheets(ws2).Cells(1, Columns.Count).End(xlToLeft).Column
Test = UserForm4.WhichTest.Value
If Test <> "" Then
colLetter = UCase(Test)
colNumber = 0
For m = 1 To Len(colLetter)
colNumber = colNumber + (Asc(Mid(colLetter, Len(colLetter) - m + 1, 1)) - 64) * 26 ^ (m - 1)
Next
columnNumber = colNumber
If (columnNumber < 24) Or (columnNumber > 136) Then
UserForm5.Show 'outside test columns - do not have time to execute further error testing...
Else 'Copy requirements from Requirements_Matrix Sheet to Output Sheet
With Sheets(ws2)
Sheets(ws2).Select
Rows("4:5000").Select
Selection.Delete Shift:=xlUp
End With
Sheets(ws1).Select
For i = 8 To Lastrow1 'find non-empty cells
If Sheets(ws1).Cells(i, 3).Interior.ColorIndex = 34 Then
Row3Value = Sheets(ws1).Cells(i, 3).Value
End If
If Sheets(ws1).Cells(i, 2).Interior.ColorIndex = 44 Then
Row2Value = Sheets(ws1).Cells(i, 2).Value
End If
If Sheets(ws1).Cells(i, 1).Interior.ColorIndex = 37 Then
Row1Value = Sheets(ws1).Cells(i, 1).Value
End If
If Sheets(ws1).Cells(i, 5) = "Requirement" Then 'Requirement Row
RqtRow = i
End If
If (Sheets(ws1).Cells(i, columnNumber).Value <> Empty) And _
Sheets(ws1).Cells(i, 3).Interior.ColorIndex <> 34 And _
Sheets(ws1).Cells(i, 2).Interior.ColorIndex <> 44 And _
Sheets(ws1).Cells(i, 1).Interior.ColorIndex <> 37 Then
k = RqtRow + 2
Increment = BlankRow2 + 2
Sheets(ws1).Select
Rows(RqtRow & ":" & k).Select 'select requirement block containing non-blank cell
Selection.Copy
Sheets(ws2).Select
Range(BlankRow2 & ":" & Increment).Select
ActiveSheet.Paste
ActiveSheet.Cells(BlankRow2, 1).Value = Row1Value
ActiveSheet.Cells(BlankRow2, 2).Value = Row2Value
ActiveSheet.Cells(BlankRow2, 3).Value = Row3Value
BlankRow2 = Increment + 2 'leave a blank row between requirements
End If
Next
End If
Else
UserForm5.Show
End If
UserForm4.WhichTest.Value = Empty
UserForm4.Hide
End Sub