Faster way for plitting data from specific sheets on differtent sheet with information from another sheet :)

DidierB

New Member
Joined
May 23, 2020
Messages
6
Office Version
  1. 365
Platform
  1. Windows
Hi,

I have a working code for splitting data based on client numbers.
My problem is it takes forever to run this.
This is only the first part below and i have to check over a hundred specific numbers.
Does anybody know a way to optimize this ?

Thanks in advance

VBA Code:
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet
    Dim Condition As Worksheet


    Set Source = ActiveWorkbook.Worksheets("Import")
    Set Target = ActiveWorkbook.Worksheets("Opsplitsing")
    Set Condition = ActiveWorkbook.Worksheets("Klantnrs")

    j = 1    'This will start copying data to Target sheet at row 1
      For Each d In Condition.Range("A2")
        For Each c In Source.Range("A2:A200")
            If d = c Then
                Source.Rows(c.Row).Copy Target.Rows(j)
                j = j + 1
            End If
        Next c
      Next d
      
          j = 10    'This will start copying data to Target sheet at row 1
      For Each d In Condition.Range("A3")
        For Each c In Source.Range("A2:A200")
            If d = c Then
                Source.Rows(c.Row).Copy Target.Rows(j)
                j = j + 1
            End If
        Next c
      Next d
      
                j = 20    'This will start copying data to Target sheet at row 1
      For Each d In Condition.Range("A4")
        For Each c In Source.Range("A2:A200")
            If d = c Then
                Source.Rows(c.Row).Copy Target.Rows(j)
                j = j + 1
            End If
        Next c
      Next d
      
                      j = 30    'This will start copying data to Target sheet at row 1
      For Each d In Condition.Range("A5")
        For Each c In Source.Range("A2:A200")
            If d = c Then
                Source.Rows(c.Row).Copy Target.Rows(j)
                j = j + 1
            End If
        Next c
      Next d
      
                          j = 40    'This will start copying data to Target sheet at row 1
      For Each d In Condition.Range("A6")
        For Each c In Source.Range("A2:A200")
            If d = c Then
                Source.Rows(c.Row).Copy Target.Rows(j)
                j = j + 1
            End If
        Next c
      Next d
      
                              j = 50    'This will start copying data to Target sheet at row 1
      For Each d In Condition.Range("A7")
        For Each c In Source.Range("A2:A200")
            If d = c Then
                Source.Rows(c.Row).Copy Target.Rows(j)
                j = j + 1
            End If
        Next c
      Next d
      
                              j = 60    'This will start copying data to Target sheet at row 1
      For Each d In Condition.Range("A8")
        For Each c In Source.Range("A2:A200")
            If d = c Then
                Source.Rows(c.Row).Copy Target.Rows(j)
                j = j + 1
            End If
        Next c
      Next d
 

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.
How about
VBA Code:
Sub DidierB()
   Dim Cl As Range
   
   For Each Cl In Sheets("Klantnrs").Range("A2:A8")
      With Sheets("Imports")
         .Range("A1").AutoFilter 1, Cl.Value
         .AutoFilter.Range.Offset(1).Copy Sheets("Opsplitsing").Range("A" & Rows.Count).End(xlUp).Offset(1)
         .AutoFilterMode = False
      End With
   Next Cl
End Sub
 
Upvote 0
Hi Fluff,

Thanks for your response.
I tried this and it filters but i need it filtered every ten rows
I have other tabs getting data out of this sheet

I changed the offset to 10 but when i do this and there are multiple records its not working correctly.
When its a single record it works.

Thanks
 
Upvote 0
Ok, how about
VBA Code:
Sub DidierB()
   Dim Cl As Range
   Dim NxtRw As Long
   
   NxtRw = 1
   For Each Cl In Sheets("Klantnrs").Range("A2:A8")
      With Sheets("Imports")
         .Range("A1").AutoFilter 1, Cl.Value
         .AutoFilter.Range.Offset(1).Copy Sheets("Opsplitsing").Range("A" & NxtRw)
         .AutoFilterMode = False
      End With
      NxtRw = (Cl.Row - 1) * 10
   Next Cl
End Sub
 
Upvote 0
Fluff you are amazing

This works like a charm

Its about 100x faster :)

Thanks for the help !
 
Upvote 0
You're welcome & thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,256
Members
448,557
Latest member
richa mishra

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top