none
ordem alfabetica e as celula mescladas RRS feed

  • Pergunta

  • boa tarde
    na planiha abaixo são lançando de forma continua e aleatoriamente nomes e datas de afastamentos.

    Como seria o codigo VBA, quando cliclasse no botão atualizar, e a planilha fique em ordem alfabetica e as celula na coluna K ficassem mesclada e com a soma dos dias de afastamento, conforme figura abaixo.

    obrigado pela atenção dispensada. 

    quinta-feira, 9 de agosto de 2012 15:50

Respostas

  • Bom dia

    Acresentei um codigo o funcionou

    Sub Exemplo()
        Dim lLast As Long
        Dim lIni As Long
        Dim lRow As Long
        Dim rng As Range
       
        With Worksheets(2).Columns("K").UnMerge
        End With
        Range("O6:O1010").Select
        Selection.Copy
        Range("K6").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
       
        With ActiveSheet
            lLast = .Cells(.Rows.Count, "B").End(xlUp).Row
            '.Columns("K").UnMerge
            .Range("A5:M" & lLast).Sort _
              Key1:=.Range("B2"), _
              Order1:=xlAscending, _
              Header:=xlYes
               
            lRow = 6
            Do
                lIni = lRow
                Do
                    lRow = lRow + 1
                    If .Cells(lRow, "B") <> .Cells(lIni, "B") Then
                        Set rng = .Cells(lIni, "K").Resize(lRow - lIni)
                        rng = WorksheetFunction.Sum(rng)
                        Application.DisplayAlerts = False
                        rng.Merge
                        Application.DisplayAlerts = True
                        Exit Do
                    End If
                Loop
            Loop While lRow <= lLast
        End With
    End Sub

    Obrigado Felipe Costa Gualberto (Benzadeus) pela atenção dispensada.



    • Marcado como Resposta JLNunes segunda-feira, 20 de agosto de 2012 14:39
    • Não Marcado como Resposta JLNunes terça-feira, 21 de agosto de 2012 00:30
    • Editado JLNunes terça-feira, 21 de agosto de 2012 01:05
    • Marcado como Resposta JLNunes terça-feira, 21 de agosto de 2012 01:06
    segunda-feira, 20 de agosto de 2012 14:38

Todas as Respostas

  • Olá, poderia disponibilizar essa pasta de trabalho para download (num site como SendSpace.com e postar o link aqui depois) para eu escrever um código de exemplo?

    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    quinta-feira, 9 de agosto de 2012 21:20
    Moderador
  • boa noite

    segue o link com a planilha.

    http://www.sendspace.com/file/hs7rka

    obs: Uso o ecxel 2003.

    obrigado.

    • Editado JLNunes sexta-feira, 10 de agosto de 2012 22:58
    sexta-feira, 10 de agosto de 2012 22:54
  • Sub Exemplo()
        Dim lLast As Long
        Dim lIni As Long
        Dim lRow As Long
        Dim rng As Range
        
        With ActiveSheet
            lLast = .Cells(.Rows.Count, "B").End(xlUp).Row
            .Range("A5:M" & lLast).Sort _
              Key1:=.Range("A2"), _
              Order1:=xlAscending, _
              Header:=xlYes
                
            lRow = 6
            Do
                lIni = lRow
                Do
                    lRow = lRow + 1
                    If .Cells(lRow, "B") <> .Cells(lIni, "B") Then
                        Set rng = .Cells(lIni, "K").Resize(lRow - lIni)
                        rng = WorksheetFunction.Sum(rng)
                        Application.DisplayAlerts = False
                        rng.Merge
                        Application.DisplayAlerts = True
                        Exit Do
                    End If
                Loop
            Loop While lRow <= lLast
        End With
    End Sub
    Note que sua Planilha deve estar desbloqueada para esse código funcionar.

    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    terça-feira, 14 de agosto de 2012 01:31
    Moderador
  • Bom dia,

    Estamos chgando lá, ao acresentar e/ou retirar algum nome da relação e atualizar, retornou um erro: Erro em tempo de execusão '1004': Erro de definição de aplicativo ou de definição de objeto.  outro problema seria ao começar um novo arquivo, como ficaria as celulas mescladas e as formulas nelas contidas. Obrigado.


    • Editado JLNunes terça-feira, 14 de agosto de 2012 13:14
    terça-feira, 14 de agosto de 2012 13:13
  • Não entendi. Você vai precisar adicionar nomes nessa lista e adicionar mais nomes cotidianamente?

    E o que seria começar um novo arquivo? Nenhum dado na planilha?


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    quarta-feira, 15 de agosto de 2012 14:55
    Moderador
  • Boa tarde

    Exatamente, suponhamos que o lancamento será de 3 em 3 meses 01/01/12 a 31/03/12, onde serão adicionado diariamente ou nao nomes nesta lista.

    começar um novo arquivo = Salvar como:lancamentos dos meses 01/04/12 a 30/06/12, onde apagaria todos os nomes e datas lancados ateriormente, e comecava um novo lancamento.

    obrigado.


    • Editado JLNunes quarta-feira, 15 de agosto de 2012 15:43
    quarta-feira, 15 de agosto de 2012 15:41
  • Basta você desmesclar as células que foram mescladas anteriormente e rodar novamente a macro. Pelo VBA, o comando para desmesclar toda a coluna seria:

    Columns("K").UnMerge


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    quinta-feira, 16 de agosto de 2012 21:51
    Moderador
  • Boa noite.

    Não funcionou, o erro continua, a formatação e as formulas nas celulas mescladas sao perdidas e nao sao recuperadas quando desmescladas.

    Obrigado.

    sexta-feira, 17 de agosto de 2012 00:09
  • Não deu certo?

    O código abaixo funciona normalmente:

    Sub Exemplo()
        Dim lLast As Long
        Dim lIni As Long
        Dim lRow As Long
        Dim rng As Range
        
        With ActiveSheet
            lLast = .Cells(.Rows.Count, "B").End(xlUp).Row
            .Columns("K").UnMerge
            .Range("A5:M" & lLast).Sort _
              Key1:=.Range("A2"), _
              Order1:=xlAscending, _
              Header:=xlYes
                
            lRow = 6
            Do
                lIni = lRow
                Do
                    lRow = lRow + 1
                    If .Cells(lRow, "B") <> .Cells(lIni, "B") Then
                        Set rng = .Cells(lIni, "K").Resize(lRow - lIni)
                        rng = WorksheetFunction.Sum(rng)
                        Application.DisplayAlerts = False
                        rng.Merge
                        Application.DisplayAlerts = True
                        Exit Do
                    End If
                Loop
            Loop While lRow <= lLast
        End With
    End Sub

    O que quer dizer sobre fórmulas? Sobre formatação, acho que precisaria de uma solução diferente dessa.


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    sábado, 18 de agosto de 2012 18:39
    Moderador
  • Boa noite

    Na colula K exitem formulas, onde é somada a data

    K6  ---> =SE(J6<I6;"ERRO!!";SE(OU(I6="";J6="");0;J6-I6+1))

    Que se perdem quando é mescladas e nao sao recuperadas quando desmescladas.

    obrigado.

    domingo, 19 de agosto de 2012 00:38
  • Não sabia que havia fórmulas.

    Nesse caso, a solução fica bem mais complicada, de forma a não valer a pena fazer o controle desses dias dessa forma.

    A verdade é que trabalhar com células mescladas numa base de dados não é recomendável.

    Sugiro que você crie uma outra tabela, separada desta, em que o nome das pessoas apareçam somente uma vez e, através da fórmula SOMASE você totalize os dias totais de férias de cada pessoa.


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    domingo, 19 de agosto de 2012 18:35
    Moderador
  • Bom dia

    Acresentei um codigo o funcionou

    Sub Exemplo()
        Dim lLast As Long
        Dim lIni As Long
        Dim lRow As Long
        Dim rng As Range
       
        With Worksheets(2).Columns("K").UnMerge
        End With
        Range("O6:O1010").Select
        Selection.Copy
        Range("K6").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
       
        With ActiveSheet
            lLast = .Cells(.Rows.Count, "B").End(xlUp).Row
            '.Columns("K").UnMerge
            .Range("A5:M" & lLast).Sort _
              Key1:=.Range("B2"), _
              Order1:=xlAscending, _
              Header:=xlYes
               
            lRow = 6
            Do
                lIni = lRow
                Do
                    lRow = lRow + 1
                    If .Cells(lRow, "B") <> .Cells(lIni, "B") Then
                        Set rng = .Cells(lIni, "K").Resize(lRow - lIni)
                        rng = WorksheetFunction.Sum(rng)
                        Application.DisplayAlerts = False
                        rng.Merge
                        Application.DisplayAlerts = True
                        Exit Do
                    End If
                Loop
            Loop While lRow <= lLast
        End With
    End Sub

    Obrigado Felipe Costa Gualberto (Benzadeus) pela atenção dispensada.



    • Marcado como Resposta JLNunes segunda-feira, 20 de agosto de 2012 14:39
    • Não Marcado como Resposta JLNunes terça-feira, 21 de agosto de 2012 00:30
    • Editado JLNunes terça-feira, 21 de agosto de 2012 01:05
    • Marcado como Resposta JLNunes terça-feira, 21 de agosto de 2012 01:06
    segunda-feira, 20 de agosto de 2012 14:38