VBA para replicar dados ate que o dado mude.

[felixxsp]

Bom dia Pessoal.

Uso um relatorio no meu trabalho, onde preciso vincular o nome do cobrador ao contrato aguardando pagamento, porém o nome do cobrador vem em uma celula separada e os contratos logo abaixo, da seguinte forma:

Cada dado vem numa celula diferente, mas aki ficou tudo junto. ehhehe (coluna A, B, C e D)

cobrador: Amanda

»»»»Status: aguardando pagamento

contrato parcela valor vencimento

7926 18 a 18 R$ 740,00 22/02/2011

8447 11 a 11 R$ 275,00 22/02/2011

8843 21 a 22 R$ 596,00 23/02/2011

6386 42 a 42 R$ 177,00 22/02/2011

7549 24 a 24 R$ 199,00 23/02/2011

8957 6 a 6 R$ 188,00 22/02/2011

8867 7 a 7 R$ 354,00 22/02/2011

8174 15 a 15 R$ 2.220, 24/02/2011

6835 33 a 35 R$ 518,00 23/02/2011

8020 15 a 17 R$ 994,00 22/02/2011

5555 16 R$ 500,00 22/02/2012

cobrador: Amaury

»»»»Status: aguardando pagamento

contrato parcela valor vencimento

8457 3 a 3 R$ 382,00 22/02/2011

7653 28 a 28 R$ 1.100, 22/02/2011

6186 2 a 2 R$ 192,00 23/02/2011

7649 31 a 31 R$ 176,00 22/02/2011

8057 34 a 34 R$ 194,00 22/02/2011

8167 6 a 6 R$ 198,00 22/02/2011

cobrador:JOAO

»»»»Status: aguardando pagamento

contrato parcela valor vencimento

8457 3 a 3 R$ 382,00 22/02/2011

8743 28 a 28 R$ 172,00 22/02/2011

6186 2 a 2 R$ 192,00 23/02/2011

7649 31 a 31 R$ 176,00 22/02/2011

8057 34 a 34 R$ 194,00 22/02/2011

8167 6 a 6 R$ 198,00 22/02/2011

então eu preciso saber uma forma de repassar o nome do cobrador para a mesma linha do contrato para ficar assim:

cobrador: Amanda

»»»»Status: aguardando pagamento

contrato parcela valor vencimento Nome Copiado

7926 18 a 18 R$ 740,00 22/02/2011 Amanda

8447 11 a 11 R$ 275,00 22/02/2011 Amanda

8843 21 a 22 R$ 596,00 23/02/2011 Amanda

6386 42 a 42 R$ 177,00 22/02/2011 Amanda

7549 24 a 24 R$ 199,00 23/02/2011 Amanda

8957 6 a 6 R$ 188,00 22/02/2011 Amanda

8867 7 a 7 R$ 354,00 22/02/2011 Amanda

8174 15 a 15 R$ 2.220, 24/02/2011 Amanda

6835 33 a 35 R$ 518,00 23/02/2011 Amanda

8020 15 a 17 R$ 994,00 22/02/2011 Amanda

5555 16 R$ 500,00 22/02/2012 Amanda

cobrador: Amaury

»»»»Status: aguardando pagamento

contrato parcela valor vencimento

8457 3 a 3 R$ 382,00 22/02/2011 Amaury

8743 28 a 28 R$ 1.100, 22/02/2011 Amaury

6186 2 a 2 R$ 192,00 23/02/2011 Amaury

7649 31 a 31 R$ 176,00 22/02/2011 Amaury

8057 34 a 34 R$ 194,00 22/02/2011 Amaury

8167 6 a 6 R$ 198,00 22/02/2011 Amaury

cobrador:JOAO

»»»»Status: aguardando pagamento

contrato parcela valor vencimento

8457 3 a 3 R$ 382,00 22/02/2011 JOAO

8743 28 a 28 R$ 172,00 22/02/2011 JOAO

6186 2 a 2 R$ 192,00 23/02/2011 JOAO

7649 31 a 31 R$ 176,00 22/02/2011 JOAO

8057 34 a 34 R$ 194,00 22/02/2011 JOAO

8167 6 a 6 R$ 198,00 22/02/2011 JOAO

Esse relatorio tem aproximadamente 80 cobradores, e não dá pra ser feito manualmente. A quantidade de linhas que vem abaixo do cobrador tambem pode variar muito, pois depende da produtividade deles.

Alguém pode me ajudar, por favor, pois já revirei a internet toda e não consegui achar uma formula/VBA que fizesse isso automaticamente.

Estou colocando em anexo uma parte da planilha para servir como teste.

Sendo que essa planilha to tamanho original tem aproximadamente 750 linhas

Link para o download da planilha:

http://www.babooforum.com.br/forum/index.p...attach_id=24540

Ficarei eternamente grato.

Obrigado.

[kuroi]

movido pra vba.

e felix, poste so uma vez cada tópico.

e o link esta quebrado.

[felixxsp]

Ok, o problema já foi resolvido com a ajuda do amigo Nelson (sonnel).

que me enviou a seguinte rotina:

Public Sub AjustarDados()

'* Autor: Nelson S

'* Alterado em: 27/03/2011

'* Contato: nelsonnsu@gmail.com

On Error GoTo PROC_ERR

Const cPLAN As String = "Plan1"

Const cPLAN_DADOS As String = "Dados"

Const cLINHA As String = "A1:M1"

Const cIDENTIF As String = "»»Operador:"

Dim strMsg As String

Dim lngTipoMsg As Long

Dim strTitMsg As String

Dim wkb As Workbook

Dim wks1 As Worksheet

Dim wks2 As Worksheet

Dim rng As Range

Dim lngLF As Long

Dim lngI As Long

Dim strOperador As String

strMsg = "Dados ajustados"

lngTipoMsg = vbInformation

strTitMsg = "OK"

Application.DisplayAlerts = False

Application.ScreenUpdating = False

Set wkb = ThisWorkbook

Set wks1 = wkb.Worksheets(cPLAN)

Set rng = wks1.Range(cLINHA)

lngLF = wks1.Range("A" & wks1.Rows.Count).End(xlUp).Row

wkb.Worksheets(cPLAN_DADOS).Delete

wkb.Worksheets.Add After:=wkb.Worksheets(wkb.Worksheets.Count)

Set wks2 = wkb.Worksheets(wkb.Worksheets.Count)

wks2.Name = cPLAN_DADOS

wks2.Range("A1:M1") = _

Array("Dt Emiss", "Nome", "Contrato", "Tipo", "Status", "N. Número", "Parcelas", _

"Receita", "Valor", "Valor Pago", "Dt Pgto", "Dt Venc", "Operador")

wks2.Range("A1:M1").Font.Bold = True

strOperador = vbNullString

For lngI = 1 To lngLF

If InStr(rng.Cells(1, 1), cIDENTIF) > 0 Then

strOperador = rng.Cells(1, 1)

End If

If IsDate(rng.Cells(1, 1)) Then

rng.Cells(1, 13) = strOperador

rng.Copy wks2.Range("A" & wks2.Rows.Count).End(xlUp).Offset(1)

rng.Cells(1, 13) = vbNullString

End If

Set rng = rng.Offset(1)

Next lngI

wks2.Columns.AutoFit

wks2.Rows("2:2").Select

ActiveWindow.FreezePanes = True

wks2.Range("A1").Select

PROC_EXIT:

Application.DisplayAlerts = True

Application.ScreenUpdating = True

If Not rng Is Nothing Then Set rng = Nothing

If Not wks2 Is Nothing Then Set wks2 = Nothing

If Not wks1 Is Nothing Then Set wks1 = Nothing

If Not wkb Is Nothing Then Set wkb = Nothing

MsgBox strMsg, lngTipoMsg, strTitMsg

Exit Sub

PROC_ERR:

If Err.Number = 9 Then

Resume Next

Err.Clear

End If

strMsg = "Erro número: " & Err.Number & vbCrLf & "Descrição: " & Err.Description & vbCrLf & _

"Módulo: AjusteDados" & vbCrLf & "Rotina: AjustarDados"

lngTipoMsg = vbCritical

strTitMsg = "Erro"

GoTo PROC_EXIT

End Sub