I am new to VBA and do not know whether my function is being correctly utilized or whether the function itself is flawed.
My subprocedure is as follows:
Sub InsertEquitiesBonds()
Dim ws As Worksheet, i As Integer
Set ws = Worksheets("PnL")
ws.Range("B3").Value = "Equities"
Worksheets("SummaryEquities").Range("MarketsEquities").Copy ws.Range("C4")
Dim LastUsedCell As Range
Set LastUsedCell = ws.Cells(ws.Rows.Count, "C").End(xlUp)
LastUsedCell.Offset(1, -1).Value = "Bonds"
Worksheets("SummaryBonds").Range("MarketsBonds").Copy LastUsedCell.Offset(2, 0)
For i = 4 To ws.Range("C" & Rows.Count).End(xlUp).Row
ws.Cells(i, 4).Value = OurFees(Range("C" & i))
Next i
Range("A1").Select
End Sub
As described in the InsertEquitiesBonds() the code works until I have to use the function OurFees that it actually just ignores. This leads me to the question am I not referring to my function correctly or if I am, is the function inevitably flawed?
OurFees() function is described as the following:
Function OurFees(rng As Range)
If rng.Value.IsEmpty = True Then
OurFees = ""
Else
Dim BasisPoint, VolMin, VolDistr As Range
If Columns("B").Find("Bonds").Row < rng.Row Then
With Worksheets("CheatSheet_Bonds")
BasisPoint = Application.WorksheetFunction.Index(Range("A5:E6"), Application.WorksheetFunction.Match(rng, Range("C5:C6"), 0), 3)
VolMin = Application.WorksheetFunction.Index(Range("A5:E6"), Application.WorksheetFunction.Match(rng, Range("D5:D6"), 0), 4)
End With
With Worksheets("SummaryBonds")
VolDistr = Application.WorksheetFunction.Index(Range("B12:C50"), Application.WorksheetFunction.Match(rng, Range("B12:B50"), 0), 2)
OurFees = Application.WorksheetFunction.Max(Range("D9") * BasisPoint, VolMin) * Range("D8") * VolDistr
End With
Else
With Worksheets("CheatSheet_Equities")
BasisPoint = Application.WorksheetFunction.Index(Range("A4:D21"), Application.WorksheetFunction.Match(rng, Range("B4:B21"), 0), 3)
VolMin = Application.WorksheetFunction.Index(Range("A4:D21"), Application.WorksheetFunction.Match(rng, Range("B4:B21"), 0), 4)
End With
With Worksheets("SummaryEquities")
VolDistr = Application.WorksheetFunction.Index(Range("B12:C40"), Application.WorksheetFunction.Match(rng, Range("B12:B40"), 0), 2)
OurFees = Application.WorksheetFunction.Max(Range("D9") * BasisPoint, VolMin) * Range("D8") * VolDistr
End With
End If
End If
End Function
try with below
For i = 4 To ws.Range("C" & Rows.Count).End(xlUp).Row
ws.Cells(i, 4).Value = OurFees(Range("C" & i))
Next i
Related
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 a data like this :
A049
A050
A051
A053
A054
A055
A056
A062
A064
A065
A066
And I want the output like :
As you can see, I want the ranges which are in consecutive order
I am trying some thing like this:
Private Sub CommandButton1_Click()
Set wb = ThisWorkbook
lastRow = wb.Sheets("Sheet1").Range("A" & wb.Sheets("Sheet1").Rows.Count).End(xlUp).Row
For i = 2 To lastRow
r = wb.Sheets("Sheet1").Range("A" & i).Value
If wb.Sheets("Sheet1").Range("A" & i).Value = wb.Sheets("Sheet1").Range("A" & i+1).Value
Next i
End Sub
But not helping me
Am feeling charitable so have tried some code which should work. It assumes your starting values are in A1 down and puts results in C1 down.
Sub x()
Dim v1, v2(), i As Long, j As Long
v1 = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
ReDim v2(1 To UBound(v1, 1), 1 To 2)
For i = LBound(v1, 1) To UBound(v1, 1)
j = j + 1
v2(j, 1) = v1(i, 1)
If i <> UBound(v1, 1) Then
Do While Val(Right(v1(i + 1, 1), 3)) = Val(Right(v1(i, 1), 3)) + 1
i = i + 1
If i = UBound(v1, 1) Then
v2(j, 2) = v1(i, 1)
Exit Do
End If
Loop
End If
If v1(i, 1) <> v2(j, 1) Then v2(j, 2) = v1(i, 1)
Next i
Range("C1").Resize(j, 2) = v2
End Sub
Try the below code
Private Sub CommandButton1_Click()
Set wb = ThisWorkbook
lastRow = wb.Sheets("Sheet1").Range("A" & wb.Sheets("Sheet1").Rows.Count).End(xlUp).Row
Dim lastNum, Binsert As Integer
Dim firstCell, lastCell, currentCell As String
Binsert = 1
lastNum = getNum(wb.Sheets("Sheet1").Range("A1").Value)
firstCell = wb.Sheets("Sheet1").Range("A1").Value
For i = 2 To lastRow
activeNum = getNum(wb.Sheets("Sheet1").Range("A" & i).Value)
currentCell = wb.Sheets("Sheet1").Range("A" & i).Value
If (activeNum - lastNum) = 1 Then
'nothing
Else
lastCell = wb.Sheets("Sheet1").Range("A" & (i - 1)).Value
wb.Sheets("Sheet1").Range("B" & Binsert).FormulaR1C1() = firstCell
If (firstCell <> lastCell) Then
wb.Sheets("Sheet1").Range("C" & Binsert).FormulaR1C1() = lastCell
End If
Binsert = Binsert + 1
firstCell = wb.Sheets("Sheet1").Range("A" & i).Value
End If
lastNum = activeNum
Next i
'last entry
wb.Sheets("Sheet1").Range("B" & Binsert).FormulaR1C1() = firstCell
If (firstCell <> currentCell) Then
wb.Sheets("Sheet1").Range("C" & Binsert).FormulaR1C1() = currentCell
End If
End Sub
Public Function getNum(ByVal num As String) As Integer
getNum = Val(Mid(num, 2))
End Function
Another solution. It loops backwards from last row to first row.
Option Explicit
Public Sub FindConsecutiveValues()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim lRow As Long 'find last row
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Dim lVal As String 'remember last value (stop value)
lVal = ws.Range("A" & lRow).Value
Const fRow As Long = 2 'define first data row
Dim i As Long
For i = lRow To fRow Step -1 'loop from last row to first row backwards
Dim iVal As Long
iVal = Val(Right(ws.Range("A" & i).Value, Len(ws.Range("A" & i).Value) - 1)) 'get value of row i without A so we can calculate
Dim bVal As Long
bVal = 0 'reset value
If i <> fRow Then 'if we are on the first row there is no value before
bVal = Val(Right(ws.Range("A" & i - 1).Value, Len(ws.Range("A" & i - 1).Value) - 1)) 'get value of row i-1 without A
End If
If iVal - 1 = bVal Then
ws.Rows(i).Delete 'delete current row
Else
If lVal <> ws.Range("A" & i).Value Then 'if start and stop value are not the same …
ws.Range("B" & i).Value = lVal 'write stop value in column B
End If
lVal = ws.Range("A" & i - 1).Value 'remember now stop value
End If
Next i
End Sub
I am completely stumped on this problem here. I created a macro that will read values from the current spreadsheet, place those values into a dictionary using row numbers as keys, create a new spreadsheet, grab the values from those dictionaries, and add them to the new spreadsheet. There are three dictionaries that are filled. I have no problem getting the values from two of the dictionaries and I even have no problems getting the first couple of values from the problematic dictionaries. But when I try to retrieve the last two values in the last For Next loop, the values are read as "" instead of an actual value. The image below is a message that I built from looping the problematic dictionary.
I had the debug loop that produced this message within the last For Next loop. As you can see each key has a value, but when I use dataN.Exist(key) for just the last two values I get "" as the value. I don't understand. The exact same code works to pull the first couple of values but not the last couple. I have even moved those values to different rows but still got the same "". Here is the entire code here below:
Sub Transfer2NewWorkbook()
Dim currentsheet As String
Dim newsheet As String
Dim analysisDate As String
Dim initial As String
Dim aInitial() As String
Dim analystInit As String
Dim aBatch() As String
Dim batch As String
Dim batchNo As String
Dim key As Variant
Dim ikey As Variant
Dim SrowN As String
Dim rowN As Integer
Dim rowD As String
Dim wb As Object
Dim dataRangeN As Range, dataRangeB As Range, dataRangeI As Range
Dim dataN As Object
Set dataN = CreateObject("Scripting.Dictionary")
Dim dataB As Object
Set dataB = CreateObject("Scripting.Dictionary")
Dim dataI As Object
Set dataI = CreateObject("Scripting.Dictionary")
Dim teststring As String
' Grab and Create filenames
currentsheet = ActiveWorkbook.Name
newsheet = currentsheet & "-" & "uploadable"
' Grab data from original spreadsheet
analysisDate = ActiveWorkbook.Sheets(1).Cells(1, 9).Value
initial = ActiveWorkbook.Sheets(1).Cells(1, 2).Value
aInitial = Split(initial, "/")
analystInit = aInitial(1)
batch = ActiveWorkbook.Sheets(1).Cells(1, 4).Value
aBatch = Split(batch, ":")
batchNo = aBatch(1)
Set dataRangeN = Range("A:A")
Set dataRangeB = Range("B:B")
Set dataRangeI = Range("I:I")
For i = 4 To dataRangeB.Rows.Count
If Not IsEmpty(dataRangeB(i, 1)) Then
If StrComp(ActiveWorkbook.Sheets(1).Cells(i, 2).Value, "End") = 0 Then
Exit For
ElseIf StrComp(ActiveWorkbook.Sheets(1).Cells(i, 2).Value, "Blank") = 0 Then
If StrComp(ActiveWorkbook.Sheets(1).Cells(i, 1).Value, "Unseeded") = 0 Or StrComp(ActiveWorkbook.Sheets(1).Cells(i, 1).Value, "Seeded") = 0 Then
If Not IsEmpty(dataRangeI(i, 1)) Then
dataN.Add i, ActiveWorkbook.Sheets(1).Cells(i, 1).Value
dataB.Add i, ActiveWorkbook.Sheets(1).Cells(i, 2).Value
dataI.Add i, ActiveWorkbook.Sheets(1).Cells(i, 9).Value
End If
End If
ElseIf StrComp(ActiveWorkbook.Sheets(1).Cells(i, 2).Value, "Check") = 0 Then
If StrComp(ActiveWorkbook.Sheets(1).Cells(i, 1).Value, "Std") = 0 Then
If Not IsEmpty(dataRangeI(i, 1)) Then
dataN.Add i, ActiveWorkbook.Sheets(1).Cells(i, 1).Value
dataB.Add i, ActiveWorkbook.Sheets(1).Cells(i, 2).Value
dataI.Add i, ActiveWorkbook.Sheets(1).Cells(i, 9).Value
End If
End If
ElseIf StrComp(ActiveWorkbook.Sheets(1).Cells(i, 2).Value, "DUP") = 0 Then
rowD = dataB.Keys()(dataB.Count - 1)
If StrComp(ActiveWorkbook.Sheets(1).Cells(i - 1, 1).Value, "CBOD") = 0 Then
dataN.Add rowD, "DUP-CBOD"
ElseIf StrComp(ActiveWorkbook.Sheets(1).Cells(i - 1, 1).Value, "BOD") = 0 Then
dataN.Add rowD, "DUP-BOD"
End If
Else
dataB.Add i, ActiveWorkbook.Sheets(1).Cells(i, 2).Value
dataI.Add i, ActiveWorkbook.Sheets(1).Cells(i, 9).Value
End If
Else
If StrComp(ActiveWorkbook.Sheets(1).Cells(i, 1).Value, "DUP") = 0 Then
rowD = dataB.Keys()(dataB.Count - 1)
If StrComp(ActiveWorkbook.Sheets(1).Cells(i - 1, 1).Value, "CBOD") = 0 Then
dataN.Add rowD, "DUP-CBOD"
ElseIf StrComp(ActiveWorkbook.Sheets(1).Cells(i - 1, 1).Value, "BOD") = 0 Then
dataN.Add rowD, "DUP-BOD"
End If
End If
End If
Next i
' Open new spreadsheet
Set wb = Workbooks.Add("C:\Users\dalythe\documents\uploadtemp.xlsx")
ActiveWorkbook.Sheets(1).Cells(2, 2).Value = analysisDate
ActiveWorkbook.Sheets(1).Cells(2, 4).Value = analystInit
ActiveWorkbook.Sheets(1).Cells(3, 5).Value = batchNo
rowN = 4
For Each key In dataB.Keys
If dataI.Exists(key) Then
SrowN = CStr(rowN)
If dataN.Exists(key) Then
ActiveWorkbook.Sheets(1).Cells(SrowN, 1).Value = dataN(key)
End If
ActiveWorkbook.Sheets(1).Cells(SrowN, 2).Value = dataB(key)
ActiveWorkbook.Sheets(1).Cells(SrowN, 3).Value = dataI(key)
rowN = CInt(SrowN)
rowN = rowN + 1
End If
Next
ActiveWorkbook.SaveAs (newsheet & ".xlsx")
End Sub
I'm currently on a project that search in a product database all non-referenced product (blank fields). When I click on the button that opens a userform, error 13 is displayed, here is the code:
Dim i As Integer
Dim j As Integer
Dim t As Integer
Dim r As Integer
t = 1
While Feuil3.Cells(t, 1) <> ""
t = t + 1
Wend
t = t - 1
For r = 2 To t
If Feuil3.Cells(r, 3) = "" Then
i = 1
While Feuil2.Cells(i, 1) <> ""
i = i + 1
Wend
Feuil2.Cells(i, 1) = Feuil3.Cells(r, 2)
End If
Next
i = 1
While Feuil2.Cells(i, 1) <> ""
i = i + 1
Wend
For j = 2 To i
If Feuil2.Cells(j, 2) = "" Then
list51.AddItem Feuil2.Cells(j, 1)
End If
Next
End Sub
It appears that the error comes from this line:If Feuil3.Cells(r, 3) = "" Then
My skills in VBA are limited, do you have any idea on how to fix this problem?
Thanks,
Have a look at this. Should do the same just a lot less iteratively
Dim Feuil2Rng As Range, Feuil3Rng As Range
Dim c
With Feuil3
Set Feuil3Rng = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
End With
For Each c In Feuil3Rng
If c.Offset(0, 2) = vbNullString Then
With Feuil2
.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1) = c.Offset(0,1)
End With
End If
Next
With Feuil2
Set Feuil2Rng = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
End With
For Each c In Feuil2Rng
If c.Offset(0, 1) = vbNullString Then
list51.AddItem c.Value2
End If
Next
I am working on my computer to automate a quote in Excel with VBA
It consists of finding duplicates so they can be summed.
For example:
I have the following information:
Click here for the Excel file
The range from A2:C4 is a group that it states there are 28 bolts, 1 nut for each bolt & 1 washer for each bolt.
A5:C7 is another group that is the same 28 bolts, 1 nut for each bolt & 1 washer for each bolt.
A11:C13 is another group but the difference is that for this one are 2 nuts & 2 washer per bolt.
So this wont be sum
This would be the result:
I have the following code where it only looks through all the cells, I can't find a way to make it look in groups or ranges.
Sub Macro1()
Dim LastRow As Long, LastColumn As Long
Dim wSrc As Worksheet: Set wSrc = Sheets("Hoja1")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With wSrc
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B1:B" & LastRow)
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column + 2
rng.AdvancedFilter Action:=xlFilterCopy, copytoRange:=.Cells(1, LastColumn), unique:=True
Z = .Cells(.Rows.Count, LastColumn).End(xlUp).Row
LastColumn = LastColumn + 1
.Cells(1, LastColumn).Value = "Total"
.Range(.Cells(2, LastColumn), .Cells(Z, LastColumn)).Formula = _
"=SUMIF(" & rng.Address & "," & .Cells(2, LastColumn - 1).Address(False, False) & "," & rng.Offset(, 1).Address & ")"
End With
With Application
.ScreenUpdating = Truek
.Calculation = xlCalculationAutomatic
End With
End Sub
Click below for the Excel file
Here is an approach that utilizes User Defined Object for the Hardware, and Hardware groups.
We could create more compact code with fewer loops, but, unless there is a significant speed issue, this is probably more readable, and can be more easily adapted to future needs.
We create two class modules (and be sure to rename them as indicated in the code).
One class module is for the hardware items, the second is for the different groups.
The hardware items properties are the description, the weight per item, and the number of items.
The hardware groups properties are a collection of Hardware items, and the Quantity of items in that group.
We then combine the hardware groups into a collection of unique hardware groups.
As the code is written, you could combine in other ways to generate other types of reports.
The results:
Class Module 1
'**Rename: cHardware**
Option Explicit
Private pDescription As String
Private pWt As Double
Private pItemCount As Long
Public Property Get Description() As String
Description = pDescription
End Property
Public Property Let Description(Value As String)
pDescription = Value
End Property
Public Property Get Wt() As Double
Wt = pWt
End Property
Public Property Let Wt(Value As Double)
pWt = Value
End Property
Public Property Get ItemCount() As Long
ItemCount = pItemCount
End Property
Public Property Let ItemCount(Value As Long)
pItemCount = Value
End Property
Class Module 2
'**Rename: cHardwareGrp**
Option Explicit
Private pHW As cHardWare
Private pHWs As Collection
Private pQty As Long
Private Sub Class_Initialize()
Set pHWs = New Collection
End Sub
Public Property Get HW() As cHardWare
Set HW = pHW
End Property
Public Property Let HW(Value As cHardWare)
Set pHW = Value
End Property
Public Property Get HWs() As Collection
Set HWs = pHWs
End Property
Public Function AddHW(Value As cHardWare)
Dim I As Long, J As Long
If pHWs.Count = 0 Then
pHWs.Add Value
Else 'Insert in sorted order
For J = pHWs.Count To 1 Step -1
If pHWs(J).Description <= Value.Description Then Exit For
Next J
If J = 0 Then
pHWs.Add Value, before:=1
Else
pHWs.Add Value, after:=J
End If
End If
End Function
Public Property Get Qty() As Long
Qty = pQty
End Property
Public Property Let Qty(Value As Long)
pQty = Value
End Property
Regular Module
Option Explicit
Sub SummarizeHW()
Dim wsRes As Worksheet, wsSrc As Worksheet, rRes As Range
Dim vSrc As Variant, vRes() As Variant
Dim cHW As cHardWare, colHW As Collection
Dim cHWG As cHardwareGrp, colHWG As Collection
Dim colUniqueHWG As Collection
Dim I As Long, J As Long, K As Long
Dim lQTY As Long
Dim S As String
Dim V As Variant
Dim RE As Object, MC As Object
'Set Source and Results Worksheets and Ranges
Set wsSrc = Worksheets("Hoja1")
Set wsRes = Worksheets("Hoja2")
Set rRes = wsRes.Cells(1, 1)
'Get Source Data
With wsSrc
vSrc = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp)) _
.Offset(columnoffset:=-1).Resize(columnsize:=3)
End With
'Set up regex to extract number of HW items in description
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = False
.Pattern = "^\((\d+)\)\s*"
.MultiLine = True
End With
'Collect unique list of hardware items
' compute the weight of each single item
Set colHW = New Collection
On Error Resume Next
For I = 2 To UBound(vSrc, 1) 'assumes header row
If vSrc(I, 1) <> "" Then lQTY = vSrc(I, 1)
Set cHW = New cHardWare
With cHW
S = vSrc(I, 2)
If RE.test(S) = True Then
Set MC = RE.Execute(S)
.ItemCount = CLng(MC(0).submatches(0))
Else
.ItemCount = 1
End If
.Wt = vSrc(I, 3) / lQTY / .ItemCount
.Description = S
colHW.Add cHW, .Description
End With
Next I
On Error GoTo 0
'Collect the Hardware Groups
'HW group starts if there is a "Qty" in column 1
Set colHWG = New Collection
For I = 2 To UBound(vSrc, 1)
If vSrc(I, 1) <> "" Then lQTY = vSrc(I, 1)
Set cHWG = New cHardwareGrp
Do
With cHWG
.HW = colHW(vSrc(I, 2))
.AddHW .HW
.Qty = lQTY
End With
I = I + 1
If I > UBound(vSrc, 1) Then Exit Do
Loop Until vSrc(I, 1) <> ""
colHWG.Add cHWG
I = I - 1
Next I
'Collect the unique hardware groups
' A group is defined by ALL of the hardware components being identical
' in both type and quantity. Therefore, we can concatenate them as a key
Set colUniqueHWG = New Collection
On Error Resume Next
For I = 1 To colHWG.Count
With colHWG(I)
ReDim V(1 To .HWs.Count)
For J = 1 To UBound(V)
V(J) = .HWs(J).Description
Next J
S = Join(V, "|")
colUniqueHWG.Add colHWG(I), S
Select Case Err.Number
Case 457 'a duplicate so add the QTY
colUniqueHWG(S).Qty = colUniqueHWG(S).Qty + .Qty
Err.Clear
Case Is <> 0 'error stop
Debug.Print Err.Number, Err.Description
End Select
End With
Next I
On Error GoTo 0
'Final Report
'# of columns = 3
'# of rows = sum of the number of HW items in each group + 1 for the header
J = 0
For I = 1 To colUniqueHWG.Count
J = J + colUniqueHWG(I).HWs.Count
Next I
ReDim vRes(0 To J, 1 To 3)
'Column headers
vRes(0, 1) = "Qty"
vRes(0, 2) = "Hardware Description"
vRes(0, 3) = "Weight"
'populate the results array'
K = 1
For I = 1 To colUniqueHWG.Count
With colUniqueHWG(I)
For J = 1 To .HWs.Count
If J = 1 Then vRes(K, 1) = .Qty
vRes(K, 2) = .HWs(J).Description
vRes(K, 3) = .Qty * .HWs(J).Wt * .HWs(J).ItemCount
K = K + 1
Next J
End With
Next I
'Write the results on a new sheet
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
.ColumnWidth = 255
With Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
End Sub
Hmmm. I see from your comments that the hardware may not always be in the same order. I will add a sorting routine to our group generation so that will be irrelevant.
EDIT: The AddHW function was modified to insert the HW items in sorted order. Since there should only be a few items, this insertion sort should be adequate.
Taking a different approach.
take advantage of the structure; three lines define it
Put results on a different tab
This input ...
generates this output ...
using this code ...
Option Explicit
Sub Macro1()
Dim LastRow As Long, LastColumn As Long
Dim wSrc As Worksheet: Set wSrc = Sheets("Hoja1")
Dim tmpSrc As Worksheet
Dim outRng As Range, inRng As Range
Dim iLoop As Long, jLoop As Long, QSum As Long
' turn off updating for speed
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' setup - tmpSrc is the working and final result
Set tmpSrc = ActiveWorkbook.Sheets.Add(, wSrc)
Set inRng = wSrc.UsedRange
inRng.Copy
tmpSrc.Range("A1").PasteSpecial (xlPasteAll)
With tmpSrc
.Name = "Hoja2"
Set outRng = .UsedRange
LastRow = .UsedRange.Rows.Count
LastColumn = .UsedRange.Columns.Count
End With
' loop down through the range
For iLoop = 2 To LastRow
If outRng.Cells(iLoop, 1) <> "" Then
QSum = outRng.Cells(iLoop, 1).Value
For jLoop = LastRow To iLoop + 1 Step -1 'loop up through the range to find a match
' matches are defined by all three rows in column B
If outRng.Cells(jLoop, 1) <> "" And _
outRng.Cells(iLoop, 2) = outRng.Cells(jLoop, 2) And _
outRng.Cells(iLoop + 1, 2) = outRng.Cells(jLoop + 1, 2) And _
outRng.Cells(iLoop + 2, 2) = outRng.Cells(jLoop + 2, 2) Then
QSum = QSum + outRng.Cells(jLoop, 1).Value
outRng.Rows(jLoop + 2).Delete
outRng.Rows(jLoop + 1).Delete
outRng.Rows(jLoop).Delete
LastRow = LastRow - 3
End If
Next jLoop
outRng.Cells(iLoop, 1).Value = QSum
End If
Next iLoop
For iLoop = 1 To 3
outRng.Columns(iLoop).ColumnWidth = inRng.Columns(iLoop).ColumnWidth
Next iLoop
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Edit:
Summing weights for bolts, nuts, and washers
Checking for case where nuts and washers appear in reverse order
n.b. I am using .UsedRange to find the last row and last column. Other methods are available.
.
Option Explicit
Sub Macro1()
Dim LastRow As Long, LastColumn As Long
Dim wSrc As Worksheet: Set wSrc = Sheets("Hoja1")
Dim tmpSrc As Worksheet
Dim outRng As Range, inRng As Range
Dim iLoop As Long, jLoop As Long, QSum As Long
Dim WSum1 As Double, WSum2 As Double, WSum3 As Double
' turn off updating for speed
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' setup - tmpSrc is the working and final result
Set tmpSrc = ActiveWorkbook.Sheets.Add(, wSrc)
Set inRng = wSrc.UsedRange
inRng.Copy
tmpSrc.Range("A1").PasteSpecial (xlPasteAll)
With tmpSrc
.Name = "Hoja2"
Set outRng = .UsedRange
LastRow = .UsedRange.Rows.Count
LastColumn = .UsedRange.Columns.Count
End With
' loop down through the range
For iLoop = 2 To LastRow
If outRng.Cells(iLoop, 1) <> "" Then
QSum = outRng.Cells(iLoop, 1).Value
WSum1 = outRng.Cells(iLoop, 3).Value
WSum2 = outRng.Cells(iLoop + 1, 3).Value
WSum3 = outRng.Cells(iLoop + 2, 3).Value
For jLoop = LastRow To iLoop + 1 Step -1 'loop up through the range to find a match
' matches are defined by all three rows in column B
If outRng.Cells(jLoop, 1) <> "" And _
outRng.Cells(iLoop, 2) = outRng.Cells(jLoop, 2) And _
outRng.Cells(iLoop + 1, 2) = outRng.Cells(jLoop + 1, 2) And _
outRng.Cells(iLoop + 2, 2) = outRng.Cells(jLoop + 2, 2) Then
QSum = QSum + outRng.Cells(jLoop, 1).Value
WSum1 = WSum1 + outRng.Cells(jLoop, 3).Value
WSum2 = WSum2 + outRng.Cells(jLoop + 1, 3).Value
WSum3 = WSum3 + outRng.Cells(jLoop + 2, 3).Value
outRng.Rows(jLoop + 2).Delete
outRng.Rows(jLoop + 1).Delete
outRng.Rows(jLoop).Delete
LastRow = LastRow - 3
Else ' check if bolts and washers are in reverse order
If outRng.Cells(jLoop, 1) <> "" And _
outRng.Cells(iLoop, 2) = outRng.Cells(jLoop, 2) And _
outRng.Cells(iLoop + 1, 2) = outRng.Cells(jLoop + 2, 2) And _
outRng.Cells(iLoop + 2, 2) = outRng.Cells(jLoop + 1, 2) Then
QSum = QSum + outRng.Cells(jLoop, 1).Value
WSum1 = WSum1 + outRng.Cells(jLoop, 3).Value
WSum2 = WSum2 + outRng.Cells(jLoop + 2, 3).Value
WSum3 = WSum3 + outRng.Cells(jLoop + 1, 3).Value
outRng.Rows(jLoop + 2).Delete
outRng.Rows(jLoop + 1).Delete
outRng.Rows(jLoop).Delete
LastRow = LastRow - 3
End If
End If
Next jLoop
outRng.Cells(iLoop, 1).Value = QSum
outRng.Cells(iLoop, 3).Value = WSum1
outRng.Cells(iLoop + 1, 3).Value = WSum2
outRng.Cells(iLoop + 2, 3).Value = WSum3
End If
Next iLoop
For iLoop = 1 To 3
outRng.Columns(iLoop).ColumnWidth = inRng.Columns(iLoop).ColumnWidth
Next iLoop
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub