Using Find in a Loop - Page 2

**Leith Ross** · #16 07-05-2009, 11:29 AM

Hello matrex,

The macro I wrote will run on Excel 2000 and later. The error you are getting is due to your version of Excel being earlier than 2000 or you are missing the scrrun.dll or it has become damaged. This is the Microsoft Scripting Runtime library which has the object reference to the Dictionary object. When the error occurs, due you see any "missing" references in your project?. Go to Tools > References... in the VBIDE to see which libraries are missing in your project. Let me know two things: What system you are using (versions of Windows and Excel), and if you are missing the scrrun.dll from your VBA project.

matrex · #17 07-05-2009, 12:51 PM

Not sure how it can be misunderstood! I thought my explanation and example were simplified enough not to create any misundertanding. I will however clarify further:

In the example there are four instances of item AAA in column A. The corresponding quantities of these four instances are 2, 1, 4 and 3 (which add up to 10). So I wanted the macro to combine these four items into one AAA item with 10 quantity and delete the other three AAA's.

AAA 2
BBB 2
AAA 1
AAA 4
FFF 3
GGG 2
GGG 1
RRR 4
AAA 3
BBB 1

Please let me if it is still not clear.

pike · #18 07-05-2009, 07:14 PM

Dude did you fix the error?

tigertiger · #19 07-06-2009, 01:29 AM

Quote:

Originally Posted by matrex

In the example there are four instances of item AAA in column A. The corresponding quantities of these four instances are 2, 1, 4 and 3 (which add up to 10). So I wanted the macro to combine these four items into one AAA item with 10 quantity and delete the other three AAA's.

ok, I had a mistake to understand your problem

Plz try testing the version 2nd SUB, like this:

Code:

Public Sub findx()
Const StartRow = 2
Dim c, firstAddress, iR As Long, eR As Long, Q, Sh0 As Worksheet

Set Sh0 = Application.ActiveSheet

eR = Sh0.Range("A" & Rows.Count).End(xlUp).Row
Dim aCo() As Byte: ReDim aCo(eR) As Byte: For iR = 0 To eR: aCo(iR) = 0: Next

For iR = StartRow To eR
    If Sh0.Cells(iR, "A").Value2 = "" Then
        aCo(iR) = 2
    Else
        If aCo(iR) = 0 Then
            firstAddress = Sh0.Cells(iR, "A").Address
            Q = Sh0.Cells(iR, "A").Offset(, 1).Value2
            
            With Sh0.Range("a" & iR & ":a" & eR)
                Set c = .Find(Sh0.Cells(iR, "A").Value2, LookIn:=xlValues, LookAt:=xlWhole)
                Do While Not c Is Nothing And c.Address <> firstAddress
                    aCo(c.Row) = 1
                    Q = Q + c.Offset(, 1).Value2
                    Set c = .FindNext(c)
                Loop
            End With
           Sh0.Cells(iR, "A").Offset(, 1).Value = Q
        End If
    End If
Next iR
For iR = eR To StartRow Step -1
   If aCo(iR) = 1 Then Sh0.Rows(iR).Delete
Next iR

End Sub

matrex · #20 07-06-2009, 02:37 PM

Quote:

Originally Posted by pike

Dude did you fix the error?

pike, yes I managed to get around the sheet error, but my problem is I can't get it to work if the columns are switched (Items are in column B and the Quantities are column A, and column C is not free). Can you please help. It has to do with Advanced Filter line. Thanks.

matrex · #21 07-06-2009, 02:44 PM

Quote:

Originally Posted by Leith Ross

Hello matrex,

The macro I wrote will run on Excel 2000 and later. The error you are getting is due to your version of Excel being earlier than 2000 or you are missing the scrrun.dll or it has become damaged. This is the Microsoft Scripting Runtime library which has the object reference to the Dictionary object. When the error occurs, due you see any "missing" references in your project?. Go to Tools > References... in the VBIDE to see which libraries are missing in your project. Let me know two things: What system you are using (versions of Windows and Excel), and if you are missing the scrrun.dll from your VBA project.

I have both Excel 2000 and 2007. In both versions I cannot access the Tools > References. Says "Error accessing the system registry". Always had this problem and could never figure out how to fix it. Tried assigning permissions in the regostry, reinstalling everything etc. No joy.

Anyway, thanks for your help.

pike · #22 07-06-2009, 05:10 PM

Hey matrex
All the codes posted will solve the first scenario
for the next sheet[s] we will need more information
like the locations of data columns in the sheets or are they random ?

matrex · #23 07-06-2009, 07:07 PM

Quote:

Originally Posted by tigertiger

ok, I had a mistake to understand your problem

Plz try testing the version 2nd SUB, like this:

Code:

Public Sub findx()
Const StartRow = 2
Dim c, firstAddress, iR As Long, eR As Long, Q, Sh0 As Worksheet

Set Sh0 = Application.ActiveSheet

eR = Sh0.Range("A" & Rows.Count).End(xlUp).Row
Dim aCo() As Byte: ReDim aCo(eR) As Byte: For iR = 0 To eR: aCo(iR) = 0: Next

For iR = StartRow To eR
    If Sh0.Cells(iR, "A").Value2 = "" Then
        aCo(iR) = 2
    Else
        If aCo(iR) = 0 Then
            firstAddress = Sh0.Cells(iR, "A").Address
            Q = Sh0.Cells(iR, "A").Offset(, 1).Value2
            
            With Sh0.Range("a" & iR & ":a" & eR)
                Set c = .Find(Sh0.Cells(iR, "A").Value2, LookIn:=xlValues, LookAt:=xlWhole)
                Do While Not c Is Nothing And c.Address <> firstAddress
                    aCo(c.Row) = 1
                    Q = Q + c.Offset(, 1).Value2
                    Set c = .FindNext(c)
                Loop
            End With
           Sh0.Cells(iR, "A").Offset(, 1).Value = Q
        End If
    End If
Next iR
For iR = eR To StartRow Step -1
   If aCo(iR) = 1 Then Sh0.Rows(iR).Delete
Next iR

End Sub

tigertiger, yes this seems to work. Takes some time to finish but does the job. Thank you very much.

matrex · #24 07-06-2009, 07:12 PM

Quote:

Originally Posted by pike

Hey matrex
All the codes posted will solve the first scenario
for the next sheet[s] we will need more information
like the locations of data columns in the sheets or are they random ?

pike, as I mentioned in my last post, it works if the data (i.e. Item Description') is in column A and the the numbers to be added (i.e. Quantity') are in column B, but I would like to modify the code for the case when these columns are switched (Item Description in B and Quantity in A).

shg · #25 07-06-2009, 07:34 PM

Quote:

Takes some time to finish but does the job.

Leith's code aggregates 10,000 rows in less than a second.

**Leith Ross** · #26 07-06-2009, 07:54 PM

Hello matrex,

After some digging, I found this article. If you have Crystal Reports 8.0 you should read it.

'Error Accessing the System Registry' Message When Displaying VB/VBA References

matrex · #27 07-06-2009, 08:34 PM

Quote:

Originally Posted by Leith Ross

Hello matrex,

After some digging, I found this article. If you have Crystal Reports 8.0 you should read it.

'Error Accessing the System Registry' Message When Displaying VB/VBA References

Hi Leith. Been there done that! In fact this is what I was referring to when I said assigning permission in the registry. Long procedure but unfortunately did not resolve the issue.

**Leith Ross** · #28 07-06-2009, 08:57 PM

Hello matrex,
In my previous post, I thought your were referring to network permission settings in the registry. I hadn't yet read the procedure outlined in the article. At this point, I have no ideas as to what is causing your problem. If I find anything else, I'll post it.

pike · #29 07-08-2009, 11:51 PM

you can play around and combin the two codes and by add an if statment to see what the first column?

Code:

Sub ptesti()
    Dim lRows As Long
    Application.ScreenUpdating = False
    With ActiveSheet.UsedRange
        lRows = .Rows.Count
     .Columns(3).Insert
     .Columns(3).FormulaR1C1 = "= SUMIF(R2C[-1]:R" & lRows & "C[-1],RC[-1],R2C[-2]:R" & lRows & "C[-2])"
     .Columns(3).Value = .Columns(3).Value
     .Columns(4).Insert
     .Columns(4).FormulaR1C1 = "=RC[-3]"
     .Columns(4).Value = .Columns(4).Value
     .Columns(1).Delete
     .Resize(, 2).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Resize(, 2), copytorange:=Range("E1"), unique:=True
     .Columns(2).Delete
    End With
Application.ScreenUpdating = True
End Sub

Welcome to the Excel Forum

Forum Statistics