Copie des lignes en fonction de la valeur de la cellule et de le coller sur une nouvelle feuille avec la même valeur de cellule nom

J'ai créé ce VBA pour copier des données à partir d'une feuille (la source) à une autre feuille (cible) basé sur les données de la 3ème feuille (condition):

Sub CopyYes()
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet
    Dim Condition As Worksheet


    Set Source = ActiveWorkbook.Worksheets("source")
    Set Target = ActiveWorkbook.Worksheets("target")
    Set Condition = ActiveWorkbook.Worksheets("condition")

    j = 1    'This will start copying data to Target sheet at row 1
      For Each d In Condition.Range("A1:A86")
        For Each c In Source.Range("B2:B1893")
            If d = c Then
                Source.Rows(c.Row).Copy Target.Rows(j)
                j = j + 1
            End If
        Next c
      Next d
End Sub

vous pouvez utiliser RemoveDuplicates() et Filtre automatique() méthodes de l'objet Range comme suit:

Option Explicit
Sub CopyRows()
Dim rngCell As Range
Dim depSheet As Worksheet
With Worksheets("DATA") '<--|refer to data sheet
.Rows(1).Insert '<--|insert a temporary header row: it'll be used for AutoFilter() method and eventually deleted
.Cells(1, 1).value = "Department" '<--| place a dummy header in the temporary header row
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Offset(, .UsedRange.Columns.Count) '<--| refer to a "helper" column out of the used range and limited to column "A" last non empty row
.value = .Offset(, -.Parent.UsedRange.Columns.Count).value '<--| duplicate departments (column "A") values in helper one
.RemoveDuplicates Columns:=Array(1), header:=xlYes '<--| leave only departments unique values in "helper" column
For Each rngCell In .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<--|loop through "helper" column departments unique values
Set depSheet = GetSheet(.Parent.Parent, rngCell.value) '<--|get or add the worksheet corresponding to current department
With .Offset(, -.Parent.UsedRange.Columns.Count + 1) '<--|refer to departments column
.AutoFilter field:=1, Criteria1:=rngCell.value '<--| filter it on current department value
With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) '<--| refer to department filtered cells
depSheet.Cells(depSheet.Rows.Count, 1).End(xlUp).Offset(1).Resize(.Cells.Count, 3).value = .Resize(, 3).value '<--|copy their values along with columns "B" and "C" ones into first empty row of the corresponding worksheet
End With
End With
Next rngCell
.ClearContents '<--| clear "helper" column
End With
.AutoFilterMode = False
.Rows(1).Delete '<--| delete temporary header row
End With
End Sub
Function GetSheet(wb As Workbook, shtName As String) As Worksheet
On Error Resume Next
Set GetSheet = wb.Worksheets(shtName) '<--| try and set a sheet with passed name
On Error GoTo 0
If GetSheet Is Nothing Then '<--| if there weas no such sheet...
Set GetSheet = wb.Worksheets.Add(After:=ActiveSheet) '<--|... add a new sheet
With GetSheet
.Name = shtName '<--|rename it after passed name
.Range("A1:C1").value = Array("DEPARTMENT", "EMPCODE", "EMPNAME") '<--| add headers
End With
End If
End Function

Mais Eileen,
Si nous avons besoin de copier les valeurs des cellules de la COLONNE E, plutôt que de la COLONNE A et de la coller sur une nouvelle feuille, puis votre réf code encore des listes de valeurs de la COLONNE A......!
Donc, nous avons juste besoin de changer vcol = 5 sur la ligne 9