Pasar información a diferentes hojas de excel

Anexo macro, agregarla en un modulo:

Option Explicit

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Hoja1") 'aqui va el nombre de tu hoja principal
Set rng = Range("BD") 'nombre del rango a distribuir

ws1.Columns("B:B").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("J1"), Unique:=True
r = Cells(Rows.Count, "J").End(xlUp).Row

Range("L1").Value = Range("B1").Value

For Each c In Range("J2:J" & r)
'add the rep name to the criteria area
ws1.Range("L2").Value = c.Value
'add new sheet and run advanced filter
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("L1:L2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
Next
ws1.Select
ws1.Columns("J:L").Delete
End Sub

Comenta si te funciono.

Hola. 

Gracias por su respuesta. 

He copiado el macro que me ha enviado en un módulo pero no me ha funcionado. No se que debo cambiar. 

La base de datos que tengo estan hasta la fila 2061. En un rango de columnas de la A hasta la AD.

Necesito distribuirlas en diferentes hojas segun los nombres de la columna B (Son aproximadamente 90 categorías).

Eh realizado una pequeña modificación, indiqueme si le funciona.

Option Explicit

Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Hoja1") 'aqui va el nombre de tu hoja principal
Range("A1:AD2061").Select
ActiveWorkbook.Names.Add Name:="BD", RefersToR1C1:= _
"=Hoja1!R1C1:R2061C30"
Range("A2").Select

Set rng = Range("BD") 'nombre del rango a distribuir

ws1.Columns("B:B").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("AF1"), Unique:=True
r = Cells(Rows.Count, "AF").End(xlUp).Row

Range("AG1").Value = Range("B1").Value

For Each c In Range("AG2:AG" & r)
'add the rep name to the criteria area
ws1.Range("AG2").Value = c.Value
'add new sheet and run advanced filter
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("AG1:AG2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
Next
ws1.Select
ws1.Columns("AF:AG").Delete
End Sub

Hola. Ya realice el cambio pero aún no me funciona. No se si tengo que cambiarle algo al macro que me envias.

Puse esta nueva parte y lo que sigue de la primera respuesta y le doy guardar. Luego cierro el archivo y al abrirlo nuevamente le habilitó los macros y le doy la opción ver macros y el ejecutar. No se si asi ea como deba hacerse

Paseme un ejemplo de su archivo se lo mando funcionando.

Saludos, no se porque le marque error ya que a mi me funciona bien.