ti-enxame.com

Copie linhas com base no valor da célula e cole em uma nova folha com o mesmo nome de valor da célula

Eu tenho procurado as mensagens relacionadas ao uso de macro para copiar linhas e colar em uma nova planilha no Excel, mas não consigo encontrar o código certo que corresponda à minha exigência. Aqui está um exemplo de dados para começar:

 Raw data

Eu tenho uma folha de dados contendo uma lista de funcionários com 3 colunas, 

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

Eu quero criar uma macro que irá dividir o conteúdo desta folha de acordo com COLUMN A - DEPARMENT e colocá-los em folhas diferentes, as novas folhas a serem nomeadas como o nome do departamento na coluna A.

O resultado final deve ser algo assim:

 End result

Este é o código que tenho até agora. Ele verifica cada linha se a célula na Coluna A é igual à próxima célula abaixo dela e, em seguida, seleciona a linha. Agora, como posso fazer a seleção ficar e adicionar mais linhas selecionadas, uma vez que verifica o valor da célula na coluna 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
3
Eileen

Eu criei este VBA para copiar dados de uma folha (fonte) para outra folha (destino) com base em dados condicionais dados na terceira folha (condição):

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

Você juntou uma boa pergunta. Tem uma descrição clara do ponto de partida e qual é o objetivo. O código que você tem é um bom começo para a resposta. No entanto, eu não tentei agrupar um monte de linhas como você queria, porque eu não tinha ideia de como fazer isso. O que eu fiz foi percorrer o intervalo de dados e, em seguida, lidar com cada linha, um de cada vez. Se a planilha de destino existisse, inseri a linha após a última linha. Se a planilha de destino não existisse, criei a nova planilha do jeito que você estava fazendo. Passe por isso com o depurador e você poderá ver como ele funciona.

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

Mas Eileen, Se precisarmos copiar valores de células de COLUMN E, em vez de COLUMN A e colar em uma nova planilha, seu código de referência ainda listará valores de COLUMN A ......! Então precisamos apenas alterar vcol = 5 na linha 9

0
Ravi Chandran

Obrigado por todas as suas respostas. Eu realmente encontrei um código muito bom que faz exatamente o que eu queria, mas esqueci de anotar o site de referência. Aqui está o código, se alguém estiver interessado:

    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

você pode usar RemoveDuplicates () e Autofilter () métodos do objeto Range da seguinte maneira:

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