web-dev-qa-db-fra.com

Copiez les lignes en fonction de la valeur de la cellule et collez-les sur une nouvelle feuille avec le même nom de valeur de cellule.

J'ai parcouru les publications relatives à l'utilisation de macros pour copier des lignes et les coller dans une nouvelle feuille dans Excel, mais je n'arrive pas à trouver le code qui correspond à mes besoins. Voici un exemple de données pour commencer:

 Raw data

J'ai une fiche de données contenant une liste des employés avec 3 colonnes, 

COLUMN A - DEPARTMENT
COLUMN B - EMPCODE
COLUMN C - EMPNAME

Je souhaite créer une macro qui scinde le contenu de cette feuille en fonction de COLONNE A - DÉPARMENT et les place sur des feuilles différentes, les nouvelles feuilles devant être nommées en tant que nom de département dans la colonne A.

Le résultat final devrait ressembler à ceci:

 End result

C'est le code que j'ai jusqu'à présent. Il vérifie chaque ligne si la cellule de la colonne A est égale à la cellule suivante située en dessous, puis sélectionne la ligne. Maintenant, comment puis-je conserver la sélection et ajouter d'autres lignes sélectionnées au fur et à mesure que la valeur de la cellule est vérifiée dans la colonne A?

Sub CopyRows()

    Dim rngMyRange As Range, rngCell As Range
    With Worksheets("DATA")
     Set rngMyRange = .Range(.Range("a1"), .Range("A65536").End(xlUp))

     For Each rngCell In rngMyRange
            If rngCell.Value = rngCell.Offset(1, 0).Value Then
            rngCell.EntireRow.Select
         End If

     Next
         Selection.Copy
         Sheets.Add After:=ActiveSheet
         Rows("1:1").Select
         Selection.Insert Shift:=xlDown
         ActiveSheet.Name = Range("A1")
 End With

 End Sub
excelvbamacros
3
Eileen

J'ai créé cette VBA pour copier les données d'une feuille (source) vers une autre feuille (cible) en fonction des données conditionnelles données dans la 3e 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
1
Vishal Agrawal

Vous avez mis en place une très bonne question. Il contient une description claire du point de départ et de l'objectif. Le code que vous avez est un bon début pour la réponse. Cependant, je n’ai pas essayé de regrouper un groupe de lignes comme vous le souhaitiez, car je ne savais pas comment procéder. Ce que j'ai fait était de parcourir la plage DATA, puis de traiter chaque ligne une par une. Si la feuille de calcul de destination existait, j'ai inséré la ligne après la dernière ligne. Si la feuille de destination n'existait pas, j'ai créé la nouvelle feuille comme vous le faisiez. Parcourez cela avec le débogueur et vous pourrez voir comment cela fonctionne.

Sub CopyRows()

Dim rngMyRange As Range, rngCell As Range
Dim sht As Worksheet
Dim LastRow As Long
Dim SheetName As String



With Worksheets("DATA")
Set rngMyRange = .Range(.Range("a1"), .Range("A65536").End(xlUp))

    For Each rngCell In rngMyRange

        rngCell.EntireRow.Select

        Selection.Copy

        If (WorksheetExists(rngCell.Value)) Then
            SheetName = rngCell.Value
            Sheets(SheetName).Select
            Set sht = ThisWorkbook.Worksheets(SheetName)
            LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).row
            Rows(LastRow + 1).Select
            Selection.Insert Shift:=xlDown
        Else
            Sheets.Add After:=ActiveSheet
            Rows("1:1").Select
            Selection.Insert Shift:=xlDown
            ActiveSheet.Name = rngCell.Value
        End If


        'Go back to the DATA sheet
        Sheets("DATA").Select
    Next

End With

End Sub

Function WorksheetExists(sName As String) As Boolean
    WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function
0
dev1998

Mais Eileen, Si nous devons copier les valeurs de cellule de COLUMN E plutôt que de COLONNE A et les coller sur une nouvelle feuille, votre code de référence répertorie toujours les valeurs de COLUMN A ......! Il suffit donc de changer vcol = 5 à la ligne 9

0
Ravi Chandran

Merci pour toutes vos réponses. En fait, j'ai trouvé un très bon code qui fait exactement ce que je voulais, mais j'ai oublié de noter le site de référence. Voici le code si quelqu'un est intéressé:

    Sub parse_data()

    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    vcol = 1
    Set ws = Sheets("DATA")
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1:J1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    For i = 2 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
    ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
    Next
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear
    For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
    Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
    Sheets(myarr(i) & "").Move After:=Worksheets(Worksheets.Count)
    End If
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
    Sheets(myarr(i) & "").Columns.AutoFit
    Next
    ws.AutoFilterMode = False
    ws.Activate
    End Sub
0
Eileen

vous pouvez utiliser RemoveDuplicates () et Autofilter () 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
0
user3598756