Vídeo recomendado
https://youtu.be/diWPPPhW-9E

DUPLICIDADE - Mesmo Nome = Unir Serviços

Fórum para dúvidas sobre os fundamentos da linguagem de programação Visual Basic no contexto do VBA
diegozl
Acabou de chegar
Acabou de chegar
Mensagens: 7
Registrado em: Dom Jun 16, 2019 9:59 pm

DUPLICIDADE - Mesmo Nome = Unir Serviços

Mensagem por diegozl »

Olá, boa noite.

Tenho uma planilha onde é informado em cada linha o Nome do Proprietário na coluna A e o Serviço desejado na coluna B. Ocorre que, as vezes, o mesmo Proprietário quer dois serviços.

Nesse caso, fica:
Joaozinho (Cel. A1) - Serv1 (Cel. B1)
Joaozinho (Cel. A2) - Serv2 (Cel. B2)

Meu objetivo seria uma macro onde, ao detectar duplicidade no nome, juntar o Serv2 à linha do Serv1, ou seja, ficar, "Joaozinho (Cel. A1) - Serv1 e Serv2 (Cel. B1)". Posteriormente, toda a linha do Serv2 seria apagada. É possível?

Encontrei, nesse mesmo fórum, opções de mesclar células e tentei adaptar ao meu caso, mas não consegui.


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


diegozl
Acabou de chegar
Acabou de chegar
Mensagens: 7
Registrado em: Dom Jun 16, 2019 9:59 pm

Re: DUPLICIDADE - Mesmo Nome = Unir Serviços

Mensagem por diegozl »

Alguém?


DANIELDDK
Acabou de chegar
Acabou de chegar
Mensagens: 8
Registrado em: Sáb Mai 11, 2019 5:15 pm

Re: DUPLICIDADE - Mesmo Nome = Unir Serviços

Mensagem por DANIELDDK »

Bom dia, tente o código abaixo:

Creio que o ajudará, é só copiar e colar, segui a formatação que passou: Coluna A (Nome), Coluna B (Serviço), o mesmo está separando por Pipe (|), se for o caso altere a simbologia a ser utilizada na linha: "Range("B" & MY_ROWS - 1).Value = Range("B" & MY_ROWS - 1).Value & " | " & Range("B" & MY_ROWS).Value"

Código: Selecionar todos

Sub CombinarCelulas()

 Columns("a:a").Select
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Planilha2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Planilha2").Sort.SortFields.Add2 Key:=Range("a1") _
        , SortOn:[*]=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Planilha2").Sort
        .SetRange Range("A2:A100000")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    MY_LAST_ROW = Range("A" & Rows.Count).End(xlUp).Row
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A2:A" & MY_LAST_ROW), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A2:B" & MY_LAST_ROW)
        .Apply
    End With
    Application.ScreenUpdating = False
    For MY_ROWS = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
        If Range("A" & MY_ROWS).Value = Range("A" & MY_ROWS - 1).Value Then
            Range("B" & MY_ROWS - 1).Value = Range("B" & MY_ROWS - 1).Value & " | " & Range("B" & MY_ROWS).Value
            Rows(MY_ROWS).Delete
        End If
    Next MY_ROWS
    Application.ScreenUpdating = True
    
     Columns("a:C").Select
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Planilha2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Planilha2").Sort.SortFields.Add2 Key:=Range("a1") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Planilha2").Sort
        .SetRange Range("A2:C100000")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
Esperto ter ajudado.


diegozl
Acabou de chegar
Acabou de chegar
Mensagens: 7
Registrado em: Dom Jun 16, 2019 9:59 pm

Re: DUPLICIDADE - Mesmo Nome = Unir Serviços

Mensagem por diegozl »

DANIELDDK escreveu: Qui Ago 06, 2020 7:49 am Bom dia, tente o código abaixo:

Creio que o ajudará, é só copiar e colar, segui a formatação que passou: Coluna A (Nome), Coluna B (Serviço), o mesmo está separando por Pipe (|), se for o caso altere a simbologia a ser utilizada na linha: "Range("B" & MY_ROWS - 1).Value = Range("B" & MY_ROWS - 1).Value & " | " & Range("B" & MY_ROWS).Value"

Código: Selecionar todos

Sub CombinarCelulas()

 Columns("a:a").Select
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Planilha2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Planilha2").Sort.SortFields.Add2 Key:=Range("a1") _
        , SortOn:[*]=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Planilha2").Sort
        .SetRange Range("A2:A100000")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    MY_LAST_ROW = Range("A" & Rows.Count).End(xlUp).Row
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A2:A" & MY_LAST_ROW), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A2:B" & MY_LAST_ROW)
        .Apply
    End With
    Application.ScreenUpdating = False
    For MY_ROWS = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
        If Range("A" & MY_ROWS).Value = Range("A" & MY_ROWS - 1).Value Then
            Range("B" & MY_ROWS - 1).Value = Range("B" & MY_ROWS - 1).Value & " | " & Range("B" & MY_ROWS).Value
            Rows(MY_ROWS).Delete
        End If
    Next MY_ROWS
    Application.ScreenUpdating = True
    
     Columns("a:C").Select
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Planilha2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Planilha2").Sort.SortFields.Add2 Key:=Range("a1") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Planilha2").Sort
        .SetRange Range("A2:C100000")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
Esperto ter ajudado.
Oi, Daniel. Boa tarde.

Primeiramente, desculpa tamanha demora. Não vi que havia tido resposta. Como entrei no fórum pra tirar outra dúvida, localizei sua mensagem.

Tentei aqui na planilha, mas dá o erro "Erro de compilação: Erro de sintaxe" e o código

Código: Selecionar todos

ActiveWorkbook.Worksheets("Planilha2").Sort.SortFields.Add2 Key:=Range("a1") _
        , SortOn:[*]=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal2
fica em vermelho, dando a entender estar incorreto. Você sabe dizer o que poderia ser?


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


DANIELDDK
Acabou de chegar
Acabou de chegar
Mensagens: 8
Registrado em: Sáb Mai 11, 2019 5:15 pm

Re: DUPLICIDADE - Mesmo Nome = Unir Serviços

Mensagem por DANIELDDK »

diegozl, boa noite! Me desculpa eu, vir aqui dar a resposta agora. rsrsrs. Ano passado foi complicado.
Lembrando que a primeira linha é o cabeçalho.
Vi que o código não era para conter aquela linha de comando.

Segue modelo da planilha.

Código: Selecionar todos

Sub CombinarCelulas()

 Columns("a:a").Select
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Planilha2").Sort.SortFields.Clear
        With ActiveWorkbook.Worksheets("Planilha2").Sort
        .SetRange Range("A2:A100000")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    MY_LAST_ROW = Range("A" & Rows.Count).End(xlUp).Row
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A2:A" & MY_LAST_ROW), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A2:B" & MY_LAST_ROW)
        .Apply
    End With
    Application.ScreenUpdating = False
    For MY_ROWS = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
        If Range("A" & MY_ROWS).Value = Range("A" & MY_ROWS - 1).Value Then
            Range("B" & MY_ROWS - 1).Value = Range("B" & MY_ROWS - 1).Value & " | " & Range("B" & MY_ROWS).Value
            Rows(MY_ROWS).Delete
        End If
    Next MY_ROWS
    Application.ScreenUpdating = True
    
     Columns("a:C").Select
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Planilha2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Planilha2").Sort.SortFields.Add2 Key:=Range("a1") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Planilha2").Sort
        .SetRange Range("A2:C100000")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
[code]
Anexos
Teste_Juntar.zip
(13.47 KiB) Baixado 79 vezes


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Responder