Is there a way to simplify my code?

**lubbamkt** · 06-06-2014, 12:34 PM

Hi,

I have a spreadsheet which needs to perform the following actions
1.) base on two range value (in Col A and B) in Worksheet1 to search and find the same value in Worksheet2 to Worksheet5
2.) if can match the the value of WS1 in any of WS2 to WS5, then Copy particular cells from one of these WS to WS1

My problem is that in reality, I got around 5000 row data in each WS2 to WS5 and around 1000 row data in WS1. I did try the code in the attachment, but it takes 38 seconds to fill just 27 rows.

Can anyone tell me how should I simplify the code so that it can run faster.
Thanks

**mikeTRON** · 06-06-2014, 02:36 PM

Can you post the code to the forum?

**lubbamkt** · 06-06-2014, 11:56 PM

Here is the code.
I reupload the workbook to the forum with elaboration, wish making it much easier to read. Thank you again!

Sub match_data_()
Dim last_row0 As Integer, last_row1 As Integer, last_row2 As Integer, last_row3 As Integer, last_row4 As Integer
Dim ID As String, Status As String
Dim C_Date As Date
Dim FilteredRange As Range, rw As Range

Application.ScreenUpdating = False
last_row0 = Sheets("1").Range("A3").End(xlDown).Row
last_row1 = Sheets("2").Range("A1").End(xlDown).Row
last_row2 = Sheets("3").Range("A1").End(xlDown).Row
last_row3 = Sheets("4").Range("A1").End(xlDown).Row
last_row4 = Sheets("5").Range("A1").End(xlDown).Row

For s = 4 To last_row0 ' step 1: determine the value on Column A and B
    ID = LCase(Sheets("1").Cells(s, 1))
    Status = Sheets("1").Cells(s, 2)

    For g = 2 To 5 ' step 2: use autofilter to help identify the WS matching step 1's values
        With Worksheets(g)
            .Range("$A$1:$HO$3186").AutoFilter Field:=12, Criteria1:=Status
            .Range("$A$1:$HO$3186").AutoFilter Field:=2, Criteria1:=ID
        End With
     
            Set FilteredRange = Worksheets(g).AutoFilter.Range.SpecialCells(xlCellTypeVisible)
            For Each rw In FilteredRange.Rows
                If rw.Row > FilteredRange.Rows.Row Then
                    Select Case g ' step 3: based on the matching result in step 2, go to corresponding WS
            
                    Case 2
                        If Status = "valid" Then ' step 4: first determine the Status
                            For i = 2 To last_row1
                                If LCase(Sheets("2").Range("B" & i)) = ID And Sheets("2").Range("L" & i) = "valid" Then ' step 5: look for value row by row
                                    Sheets("2").Range("E" & i & ":K" & i).Copy Sheets("1").Range("C" & s & ": I" & s) ' step 6: if matched, copy cells
                                    GoTo ABC ' step 7: if matched, exit and start another step 1
                                End If
                            Next i
                    
                        ElseIf Status = "one-time" Then
                            C_Date = "1900-01-01"
                                For i = 2 To last_row1
                                    If Sheets("2").Range("A" & i) = ID And Sheets("2").Range("L" & i) = "one-time" And _
                                    Sheets("2").Range("M" & i) > C_Date Then
                                        C_Date = Sheets("2").Range("M" & i)
                                        Sheets("2").Range("E" & i & ":K" & i).Copy Sheets("1").Range("C" & s & ": I" & s)
                                        GoTo ABC
                                    End If
                                Next i
                        End If
            
                    Case 3
                        If Status = "valid" Then
                            For i = 2 To last_row2
                                If LCase(Sheets("3").Range("B" & i)) = ID And Sheets("3").Range("EJ" & i) = "valid" Then
                                    Sheets("3").Range("E" & i & ":K" & i).Copy Sheets("1").Range("C" & s & ": I" & s)
                                    GoTo ABC
                                Exit For
                                End If
                            Next i
                    
                        ElseIf Status = "one-time" Then
                            C_Date = "1900-01-01"
                                For i = 2 To last_row2
                                    If Sheets("3").Range("A" & i) = ID And Sheets("3").Range("EJ" & i) = "one-time" And _
                                    Sheets("3").Range("M" & i) > C_Date Then
                                        C_Date = Sheets("3").Range("M" & i)
                                        Sheets("3").Range("E" & i & ":K" & i).Copy Sheets("1").Range("C" & s & ": I" & s)
                                        GoTo ABC
                                    End If
                                Next i
                        End If
                
                    Case 4
                        If Status = "valid" Then
                            For i = 2 To last_row3
                                If LCase(Sheets("4").Range("B" & i)) = ID And Sheets("4").Range("EJ" & i) = "valid" Then
                                    Sheets("4").Range("E" & i & ":K" & i).Copy Sheets("1").Range("C" & s & ": I" & s)
                                    GoTo ABC
                                End If
                            Next i
                    
                        ElseIf Status = "one-time" Then
                            C_Date = "1900-01-01"
                                For i = 2 To last_row3
                                    If Sheets("4").Range("A" & i) = ID And Sheets("4").Range("EJ" & i) = "one-time" And _
                                    Sheets("4").Range("M" & i) > C_Date Then
                                        C_Date = Sheets("4").Range("M" & i)
                                        Sheets("4").Range("E" & i & ":K" & i).Copy Sheets("1").Range("C" & s & ": I" & s)
                                        GoTo ABC
                                    End If
                                Next i
                        End If
                
                    Case 5
                        If Status = "valid" Then
                            For i = 2 To last_row4
                                If LCase(Sheets("5").Range("B" & i)) = ID And Sheets("5").Range("EJ" & i) = "valid" Then
                                    Sheets("5").Range("E" & i & ":K" & i).Copy Sheets("1").Range("C" & s & ": I" & s)
                                    GoTo ABC
                                End If
                        Next i
                    
                        ElseIf Status = "one-time" Then
                            C_Date = "1900-01-01"
                                For i = 2 To last_row4
                                    If Sheets("5").Range("A" & i) = ID And Sheets("5").Range("EJ" & i) = "one-time" And _
                                    Sheets("5").Range("M" & i) > C_Date Then
                                        C_Date = Sheets("5").Range("M" & i)
                                       Sheets("5").Range("E" & i & ":K" & i).Copy Sheets("1").Range("C" & s & ": I" & s)
                                       GoTo ABC
                                     End If
                                Next i
                         End If
                    End Select
                End If
            Next
    Next
ABC:
Next

Application.ScreenUpdating = True
End Sub

**protonLeah** · 06-07-2014, 01:42 AM

Option Explicit
Sub FindGID()
    Dim GroupID     As Range, _
        Status      As String, _
        LastGID     As Long, _
        TestID      As Variant, _
        SearchSheet As Variant, _
        IDFound     As Variant, _
        SearchBottm As Long
    
    With Sheets("1")
        LastGID = .Cells(Rows.Count, "A").End(xlUp).Row
        Set GroupID = .Range("A4:A" & LastGID)
        
        For Each SearchSheet In ThisWorkbook.Sheets
            If SearchSheet.Name <> "1" Then
                SearchBottm = SearchSheet.Cells(Rows.Count, "A").End(xlUp).Row
                For Each TestID In GroupID
                    Status = TestID.Offset(columnOffset:=1).Value
                    Set IDFound = SearchSheet.Range("B2:B" & SearchBottm).Find(TestID)
                    If Not IDFound Is Nothing Then
                        If IDFound.Offset(columnOffset:=10) = Status Then
                            TestID.Offset(0, 2).Resize(columnsize:=7).Value = IDFound.Offset(columnOffset:=3).Resize(columnsize:=7).Value
                        End If
                    End If
                Next TestID
            End If  'searching this one
        Next SearchSheet
    End With
End Sub

**lubbamkt** · 06-07-2014, 01:58 AM

Hi protonLeah, thank you so much!

Originally Posted by protonLeah

Option Explicit
Sub FindGID()
    Dim GroupID     As Range, _
        Status      As String, _
        LastGID     As Long, _
        TestID      As Variant, _
        SearchSheet As Variant, _
        IDFound     As Variant, _
        SearchBottm As Long
    
    With Sheets("1")
        LastGID = .Cells(Rows.Count, "A").End(xlUp).Row
        Set GroupID = .Range("A4:A" & LastGID)
        
        For Each SearchSheet In ThisWorkbook.Sheets
            If SearchSheet.Name <> "1" Then
                SearchBottm = SearchSheet.Cells(Rows.Count, "A").End(xlUp).Row
                For Each TestID In GroupID
                    Status = TestID.Offset(columnOffset:=1).Value
                    Set IDFound = SearchSheet.Range("B2:B" & SearchBottm).Find(TestID)
                    If Not IDFound Is Nothing Then
                        If IDFound.Offset(columnOffset:=10) = Status Then
                            TestID.Offset(0, 2).Resize(columnsize:=7).Value = IDFound.Offset(columnOffset:=3).Resize(columnsize:=7).Value
                        End If
                    End If
                Next TestID
            End If  'searching this one
        Next SearchSheet
    End With
End Sub

**lubbamkt** · 06-07-2014, 02:11 AM

Hi protonLeah,
Is it possible to use array to first save the result and paste them only once after searching?

Originally Posted by protonLeah

Option Explicit
Sub FindGID()
    Dim GroupID     As Range, _
        Status      As String, _
        LastGID     As Long, _
        TestID      As Variant, _
        SearchSheet As Variant, _
        IDFound     As Variant, _
        SearchBottm As Long
    
    With Sheets("1")
        LastGID = .Cells(Rows.Count, "A").End(xlUp).Row
        Set GroupID = .Range("A4:A" & LastGID)
        
        For Each SearchSheet In ThisWorkbook.Sheets
            If SearchSheet.Name <> "1" Then
                SearchBottm = SearchSheet.Cells(Rows.Count, "A").End(xlUp).Row
                For Each TestID In GroupID
                    Status = TestID.Offset(columnOffset:=1).Value
                    Set IDFound = SearchSheet.Range("B2:B" & SearchBottm).Find(TestID)
                    If Not IDFound Is Nothing Then
                        If IDFound.Offset(columnOffset:=10) = Status Then
                            TestID.Offset(0, 2).Resize(columnsize:=7).Value = IDFound.Offset(columnOffset:=3).Resize(columnsize:=7).Value
                        End If
                    End If
                Next TestID
            End If  'searching this one
        Next SearchSheet
    End With
End Sub

**lubbamkt** · 06-07-2014, 09:58 AM

Can anyone give me a hand pls?

**protonLeah** · 06-07-2014, 08:47 PM

I'll have a look Sunday.

**lubbamkt** · 06-07-2014, 11:38 PM

Sure. Np. Thanks in advance

**protonLeah** · 06-08-2014, 03:14 PM

Sub FindGID()
    Dim GroupID     As Range, _
        Status      As String, _
        Ndx         As Long, _
        LastGID     As Long, _
        SearchBottm As Long, _
        TestID      As Variant, _
        SearchSheet As Variant, _
        IDFound     As Variant

    With Sheets("1")
        LastGID = .Cells(Rows.Count, "A").End(xlUp).Row
        Set GroupID = .Range("A4:A" & LastGID)
        ReDim testarray(4 To LastGID, 1 To 7)
        
        For Each SearchSheet In ThisWorkbook.Sheets
            If SearchSheet.Name <> "1" Then
                SearchBottm = SearchSheet.Cells(Rows.Count, "A").End(xlUp).Row
                For Each TestID In GroupID
                    Status = TestID.Offset(columnOffset:=1).Value
                    Set IDFound = SearchSheet.Range("B2:B" & SearchBottm).Find(TestID)
                    If Not IDFound Is Nothing Then
                        If IDFound.Offset(columnOffset:=10) = Status Then
                            For Ndx = 1 To 7
                                testarray(TestID.Row, Ndx) = IDFound.Offset(columnOffset:=1 + Ndx).Value
                            Next Ndx
                        End If
                    End If
                Next TestID
            End If  'searching this sheet
        Next SearchSheet
        .Range("C4:I27").Value = testarray
    End With 'SHEET 1
End Sub

**jindon** · 06-08-2014, 04:09 PM

See if this is faster.

Sub test()
    Dim a, b, i As Long, ii As Long, iii As Long
    Dim ws As Worksheet, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Sheets("1").Range("a3").CurrentRegion
        a = .Value
        For i = 2 To UBound(a, 1)
            dic(a(i, 1) & Chr(2) & a(i, 2)) = i
        Next
        For Each ws In Worksheets
            If Not ws Is .Parent Then
                b = ws.Cells(1).CurrentRegion.Value
                For ii = 2 To UBound(b, 1)
                    If dic.exists(b(ii, 2) & Chr(2) & b(ii, 12)) Then
                        For iii = 5 To 11
                            a(dic(b(ii, 2) & Chr(2) & b(ii, 12)), iii - 2) = b(ii, iii)
                        Next
                    End If
                Next
            End If
        Next
        .Value = a
    End With
End Sub

Is there a way to simplify my code?

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Is there a way to simplify my code?

Re: Is there a way to simplify my code?

Re: Is there a way to simplify my code?

Re: Is there a way to simplify my code?

Re: Is there a way to simplify my code?

Re: Is there a way to simplify my code?

Re: Is there a way to simplify my code?

Re: Is there a way to simplify my code?

Re: Is there a way to simplify my code?

Thread Information

Users Browsing this Thread

Similar Threads

How to simplify code?

[SOLVED] Simplify VBA Code

hi can anyone simplify this old bit of code

[SOLVED] Simplify Code

Simplify this code

Bookmarks

Bookmarks

Posting Permissions