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
 

Some videos you may like

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,345
Office Version
  1. 365
Platform
  1. Windows
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
 

DidierB

New Member
Joined
May 23, 2020
Messages
6
Office Version
  1. 365
Platform
  1. Windows
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
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,345
Office Version
  1. 365
Platform
  1. Windows
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
 

DidierB

New Member
Joined
May 23, 2020
Messages
6
Office Version
  1. 365
Platform
  1. Windows
Fluff you are amazing

This works like a charm

Its about 100x faster :)

Thanks for the help !
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,345
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,123,452
Messages
5,601,740
Members
414,470
Latest member
glukemey

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
Top