Save several workbooks according to a filtered list

[Flavien]

Hello Everybody!

I would like to save several workbooks according to a filtered list, but unfortunately the macro reads all the lines of the chart including hidden lines.

Do you have a solution?

Thank you for your help!

Please find below the program:

Sub Creer_classeur_GCU()


Dim wbToDupe As Workbook
Dim wsExtr As Worksheet
Dim rVar As Range
Dim NewName As String
Dim i As Long

Application.ScreenUpdating = False

Workbooks.Open Filename:="P:\01-Qualité\K - Qualité Usinage\05 - CREATION PCP PREMIER NIVEAU\12-DC-11 - Gamme contrôle usinage - v00.xlsx"


Const DestFolder As String = "P:\01-Qualité\K - Qualité Usinage\05 - CREATION PCP PREMIER NIVEAU" '<- Edit as required

Set wbToDupe = Workbooks("12-DC-11 - Gamme contrôle usinage - v00.xlsx") '<- Edit as required
Set wsExtr = ThisWorkbook.Sheets("EXTRACTION")
Set rVar = wbToDupe.Sheets("TABLE - Cartouche").ListObjects(1).DataBodyRange.Cells(1, 2) 'renvoie à une colonne à l'exception de l'entête
With wsExtr
For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row
.Range("A" & i).Resize(, 6).Copy
rVar.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
NewName = "P" & rVar.Cells(1, 1).Value & " - " & rVar.Cells(2, 1).Value & " - " & " GCU - V00.xlsx"
wbToDupe.SaveAs Filename:=NewName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Set wbToDupe = Workbooks(NewName)
Set rVar = wbToDupe.Sheets("TABLE - Cartouche").ListObjects(1).DataBodyRange.Cells(1, 2)
Next i
End With
wbToDupe.Close
Application.ScreenUpdating = True

End Sub

****

Thank you for help!!

 

[Peter_SSs]

This is really a continuation of this thread. Please continue there.