+ Reply to Thread
Results 1 to 4 of 4

Combining two Arrays with different criteria's

Hybrid View

  1. #1
    Registered User
    Join Date
    07-21-2010
    Location
    Largo, FL
    MS-Off Ver
    Excel 2003 and 2007
    Posts
    54

    Combining two Arrays with different criteria's

    I'm stumped. For the life of me, I can not get these two Subs to work as one. Can someone take a look and give me a suggestion...

    Sub JabClass()
    
        Dim rngFound As Range, rngToDelete As Range
        Dim strFirstAddress As String
        Dim varList As Variant
        Dim lngCounter As Long
    
        Application.ScreenUpdating = False
        
        varList = VBA.Array("*BATTERY*", "*LABEL*", "*DIE CUT*", "*KEYPAD*", "*MECHANICAL*", _
        "*METAL*", "*Assem*", "*PACKAG*", "*PCB*", "*PLASTICS*", "*PREPPED*", "*PRINT*", _
        "*PURCHASED*", "*PWA*", "*NON MANUF*", "*UNCLASS*")
        
        For lngCounter = LBound(varList) To UBound(varList)
        
            With Sheet1.Range("C:C")
                Set rngFound = .Find( _
                                    What:=varList(lngCounter), _
                                    Lookat:=xlWhole, _
                                    SearchOrder:=xlByRows, _
                                    SearchDirection:=xlNext, _
                                    MatchCase:=True _
                                        )
    
                
                If Not rngFound Is Nothing Then
                    If rngToDelete Is Nothing Then
                        Set rngToDelete = rngFound
                    Else
                        Set rngToDelete = Application.Union(rngToDelete, rngFound)
                    End If
                    
                    strFirstAddress = rngFound.Address
                    Set rngFound = .FindNext(After:=rngFound)
                    
                    Do Until rngFound.Address = strFirstAddress
                        Set rngToDelete = Application.Union(rngToDelete, rngFound)
                        Set rngFound = .FindNext(After:=rngFound)
                    Loop
                End If
            End With
        Next lngCounter
        
        If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete
    
        Application.ScreenUpdating = True
    
    End Sub
    ***********************************************************************************

    Sub JabMFR()
    
        Dim rngFound As Range, rngToDelete As Range
        Dim strFirstAddress As String
        Dim varList As Variant
        Dim lngCounter As Long
    
        Application.ScreenUpdating = False
        
        varList = VBA.Array("*AAVID*", "*ALUMINUM*", "*ARROW ELECTR*", "*BALL CHAIN*", "*BEARING*", "*BELTING*", _
    	"*BOOTH FELT*", "*BRISTOL TAPE*", "*BSC FILTERS*", "*BUMPER SPECIALITIES*", "*CLEAN TEAM PRODUCTS*", "*DIE CAST*", _
    	"*DIE CUT*", "*DIEMASTERS*", "*DIGI KEY*", "*DIGIKEY*", "*DIGI-KEY*", "*ENDRIES INTER*", "*FAB*", "*FIBREGLASS*", _
    	"*FOAMS", "*FSP GROUP*", "*FU YU MAN*", "*GASKET*", "*LABEL*", "*LEATHER*", "*MACHIINERY*", "*MACHINING*", _
    	"*MAG LAYERS*", "*METAL*", "*MOLD*", "*NMB MINEBEA*", "*ORIENTAL PRINTED CIRC*", "*PACK**", "*PLASTEC*", "*PLASTIC*", _
    	"*PRINTING*", "*PRINTEC H.T.*", "*RICHCO INC*", "*RUBBER*", "*SCREWS*", "*SEALED AIR*", "*SHANGHAI HONGTAO *", _
    	"*SIGNATURE CABLE MANU*", "*SPRING*", "*STAMP*", "*STOCKER HINGE**", "*TELFORD SERVICE*", "*TOOL*", "*WIRE & CABLE*", _
    	"*ZEBRA TECHNOLOGIES*")
        
        For lngCounter = LBound(varList) To UBound(varList)
        
            With Sheet1.Range("F:F")
                Set rngFound = .Find( _
                                    What:=varList(lngCounter), _
                                    Lookat:=xlWhole, _
                                    SearchOrder:=xlByRows, _
                                    SearchDirection:=xlNext, _
                                    MatchCase:=True _
                                        )
    
                
                If Not rngFound Is Nothing Then
                    If rngToDelete Is Nothing Then
                        Set rngToDelete = rngFound
                    Else
                        Set rngToDelete = Application.Union(rngToDelete, rngFound)
                    End If
                    
                    strFirstAddress = rngFound.Address
                    Set rngFound = .FindNext(After:=rngFound)
                    
                    Do Until rngFound.Address = strFirstAddress
                        Set rngToDelete = Application.Union(rngToDelete, rngFound)
                        Set rngFound = .FindNext(After:=rngFound)
                    Loop
                End If
            End With
        Next lngCounter
        
        If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete
    
        Application.ScreenUpdating = True
    
    End Sub

  2. #2
    Forum Expert Mordred's Avatar
    Join Date
    07-06-2010
    Location
    Winnipeg, Canada
    MS-Off Ver
    2007, 2010
    Posts
    2,787

    Re: Combining two Arrays with different criteria's

    Can you define "work as one"?
    If you're happy with someone's help, click that little star at the bottom left of their post to give them Reps.

    ---Keep on Coding in the Free World---

  3. #3
    Registered User
    Join Date
    07-21-2010
    Location
    Largo, FL
    MS-Off Ver
    Excel 2003 and 2007
    Posts
    54

    Re: Combining two Arrays with different criteria's

    I would like these two macro's to be just one.

  4. #4
    Registered User
    Join Date
    07-21-2010
    Location
    Largo, FL
    MS-Off Ver
    Excel 2003 and 2007
    Posts
    54

    Re: Combining two Arrays with different criteria's

    Just to clarify, the top code runs in Column C. The second code runs in column F...the Arrays are different.

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1