[jorgerod]

olá elza,

acrescentei, para evitar o aparecimento do tal erro, a peça de código on error resume next.

no que diz respeito ao caso de se apagar o conteúdo de uma célula das folhas mensais e que contenham comentário, adicionei também um pouco de código que faz com que ao apagar e fazer enter, o comentário também desaparece.

bom, verifica, adapta e diz qq coisa, ok?

fica bem.

em anexo, a folha com os novos códigos, que contêm a data de hoje para ser mais perceptível 🙂

TesteVBA1Guardadoautomaticamente.xlsm

[jorgerod]

ainda bem, elza!!!! sempre às ordens!!! 🙂

[jorgerod]

elza,

quanto à tua pergunta: “como é que se aplica o código a todo o documento? na folha lotes, ao clicar no lote, ele procurava em todas as folhas o n.º de lote e colocava o comentário na respectiva célula.”, espero que a resposta esteja no seguinte código (envio também a folha). diz qq coisa, ok?


'---------------------------------------------------------------------------------------
' procedure : worksheet_beforedoubleclick
' author : jrod
' date : 02/04/2013
' purpose :
'---------------------------------------------------------------------------------------
'
private sub worksheet_beforedoubleclick(byval target as range, cancel as boolean)

dim rcell as string
dim rcell1 as string
dim xpto as string
dim xpto1 as string
dim rng as range
dim vdata as variant
dim firstaddress
dim txmes(1 to 3) as string ' novo - para os 12 meses, terá que ser 1 to 12
dim i as integer

txmes(1) = "fev" ' novo - estes serão os nomes das folhas
txmes(2) = "mar" ' novo - estes serão os nomes das folhas
txmes(3) = "abr" ' novo - estes serão os nomes das folhas, etc, etc...

sheets(1).select ' novo - coloquei a folha lotes, como sendo a primeira folha

if not intersect(target, range("d:d")) is nothing then

cancel = true
vdata = activecell.value

rcell = activecell.offset(0, 13)

if rcell = "" then
xpto = msgbox(prompt:="falta chegar:" & chr(10) & "nada", title:="falta chegar")
else
xpto = msgbox(prompt:="falta chegar:" & chr(10) & rcell, title:="falta chegar")
end if

rcell1 = activecell.offset(0, 14)

if rcell1 = "" then
xpto1 = msgbox(prompt:="falta aprovação:" & chr(10) & chr(10) & "nada", title:="falta aprovação")
else
xpto1 = msgbox(prompt:="falta aprovação:" & chr(10) & chr(10) & rcell1, title:="falta aprovação")
end if

for i = 1 to 3 ' novo - tem a ver com o número de folhas

with worksheets(txmes(i)).range("a1:r500")
set rng = .find(what:=vdata, _
after:=.cells(.cells.count), _
lookin:=xlvalues, _
lookat:=xlwhole, _
searchorder:=xlbyrows, _
searchdirection:=xlnext, _
matchcase:=false)

if not rng is nothing then ' parte nova e acrescentada
firstaddress = rng.address ' parte nova e acrescentada

do ' parte nova e acrescentada
if not rng.comment is nothing then rng.comment.delete ' novo - apaga comentário

if rng.comment is nothing then rng.addcomment

rng.comment.text "falta chegar:" & chr(10) _
& rcell & chr(10) & chr(10) & "falta aprovação:" & chr(10) _
& chr(10) & rcell1 & chr(10) & chr(10) & format(now)
rng.comment.shape.textframe.characters.font.bold = true ' parte nova e acrescentada, para pôr o comentário a bold
rng.comment.shape.textframe.autosize = true ' parte nova e acrescentada, para automatizar o tamanho do comentário

set rng = .findnext(rng) ' parte nova e acrescentada

loop while not rng is nothing and rng.address firstaddress ' parte nova e acrescentada

end if

end with

next i
end if

end sub


TesteVBA1Guardadoautomaticamente.xlsm

[jorgerod]

elza,

duas situações (desculpa se não percebi 🙂 🙂 ): o bold é para o comentário, ou para o valor da célula da folha abr?

se for para o comentário, tens que adicionar o código que te indico, no segmento que, igualmente, assinalo:

rng.comment.shape.textframe.characters.font.bold = true

if not rng is nothing then ' parte nova e acrescentada
firstaddress = rng.address ' parte nova e acrescentada

do ' parte nova e acrescentada
if not (rng.comment is nothing) then rng.comment.delete ' novo - apaga comentário

if rng.comment is nothing then rng.addcomment

rng.comment.text "falta chegar:" & chr(10) _
& rcell & chr(10) & chr(10) & "falta aprovação:" & chr(10) _
& chr(10) & rcell1 & chr(10) & chr(10) & format(now)
rng.comment.shape.textframe.characters.font.bold = true ' parte nova e acrescentada, para pôr o comentário a bold
set rng = .findnext(rng) ' parte nova e acrescentada

loop while not rng is nothing and rng.address firstaddress ' parte nova e acrescentada
end if

se for para a célula, então a linha de código no segmento que assinalo será:

activecell.font.bold = true

if sheets(2).range(rcell) = "ok" and sheets(2).range(rcell1) = "ok" then
activecell.font.color = vbgreen
activecell.font.bold = true

elseif sheets(2).range(rcell) = "ok" and sheets(2).range(rcell1) = "" then
activecell.font.color = vbmagenta
activecell.font.bold = true
else
activecell.font.color = vbred
activecell.font.bold = true
end if


[jorgerod]

quanto ao teu primeiro parágrafo – estive a experimentar e, se alterar alguma coisa numa das células correspondentes ao número da coluna d, tens sempre que dar um duplo clique nessa célula, para que o comentário seja actualizado.

quanto ao resto, já vou ver, ok?

[jorgerod]

olá elza,

há uma pequena nuance a ter em conta no tipo da variável vdata, no procedimento worksheet_beforedoubleclick. está como “long”, mas deverá ser como “variant”, uma vez que tu utilizas número ou texto.

fica bem.

[jorgerod]

olá elza (mais uma vez b) ),

abaixo, envio-te novamente o ficheiro de exemplo, desta vez com uma espécie de formatação condicional, na folha abr. como funciona: ou digitas o número que queres na célula pretendida, ou carregas em f2, activas assim a célula desejada e carregas em enter. se tudo correr bem, o código vai ler à folha lotes e procura pelo valor que está contido na tal célula da folha abr e verifica se nas células correspondentes das colunas m e n, se encontram os ok’s… conforme tenha ok–ok, verde; ok–nada, magenta; nada-nada, encarnado.

experimenta e diz qq coisa, ok?

abaixo o código e a folha:

'---------------------------------------------------------------------------------------
' procedure : worksheet_change
' author : jrod
' date : 31/03/2013
' purpose :
'---------------------------------------------------------------------------------------
'
private sub worksheet_change(byval target as range)

dim rcell as string
dim rcell1 as string
dim rng as range
dim vdata as long
dim rnew as string

sheets(1).select

if not intersect(target, range("d:r")) is nothing then

cancel = true
activecell.offset(-1, 0).select

vdata = activecell.value

with sheets(2).range("d:d")
set rng = .find(what:=vdata, _
after:=.cells(.cells.count), _
lookin:=xlvalues, _
lookat:=xlwhole, _
searchorder:=xlbyrows, _
searchdirection:=xlnext, _
matchcase:=false)

if not rng is nothing then
rcell = rng.offset(0, 9).address
rcell1 = rng.offset(0, 10).address
msgbox vdata & "--" & rcell & "/" & rcell1 ' mensagem apenas para controlo...
end if

end with

if sheets(2).range(rcell) = "ok" and sheets(2).range(rcell1) = "ok" then
activecell.font.color = vbgreen
elseif sheets(2).range(rcell) = "ok" and sheets(2).range(rcell1) = "" then
activecell.font.color = vbmagenta
else
activecell.font.color = vbred
end if

end if

end sub


TesteVBA1_2013-03-31.xlsm

Attachments:

You must be logged in to view attached files.

[jorgerod]

olá elza,

julgo que já tratei do assunto relacionado com os comentários. quanto à formatação condicional, vou tentar ver logo que tenha oportunidade.

vê o seguinte código (mando-te o ficheiro também com a alteração exemplificada na folha abr):

'---------------------------------------------------------------------------------------
' procedure : worksheet_beforedoubleclick
' author : jrod
' date : 28/03/2013
' purpose :
'---------------------------------------------------------------------------------------
'
private sub worksheet_beforedoubleclick(byval target as range, cancel as boolean)

dim rcell as string
dim rcell1 as string
dim xpto as string
dim xpto1 as string
dim rng as range
dim vdata as long
dim firstaddress as string

sheets(2).select

if not intersect(target, range("d:d")) is nothing then

cancel = true
vdata = activecell.value

rcell = activecell.offset(0, 13)

if rcell = "" then
xpto = msgbox(prompt:="falta chegar:" & chr(10) & "nada", title:="falta chegar")
else
xpto = msgbox(prompt:="falta chegar:" & chr(10) & rcell, title:="falta chegar")
end if

rcell1 = activecell.offset(0, 14)

if rcell1 = "" then
xpto1 = msgbox(prompt:="falta aprovação:" & chr(10) & chr(10) & "nada", title:="falta aprovação")
else
xpto1 = msgbox(prompt:="falta aprovação:" & chr(10) & chr(10) & rcell1, title:="falta aprovação")
end if

with sheets(1).range("a1:r500")
set rng = .find(what:=vdata, _
after:=.cells(.cells.count), _
lookin:=xlvalues, _
lookat:=xlwhole, _
searchorder:=xlbyrows, _
searchdirection:=xlnext, _
matchcase:=false)

if not rng is nothing then ' parte nova e acrescentada
firstaddress = rng.address ' parte nova e acrescentada

do ' parte nova e acrescentada
if rng.comment is nothing then rng.addcomment

rng.comment.text "falta chegar:" & chr(10) _
& rcell & chr(10) & chr(10) & "falta aprovação:" & chr(10) _
& chr(10) & rcell1 & chr(10) & chr(10) & format(now)

set rng = .findnext(rng) ' parte nova e acrescentada

loop while not rng is nothing and rng.address firstaddress ' parte nova e acrescentada
end if
end with

sheets(1).select

call comments_autosize

end if

end sub

TesteVBA1_2013-03-30.xlsm

[jorgerod]

leanclaudio,

manda planilha com o exemplo que pretendes, para melhor entendimento, ok?

fica bem.

[jorgerod]

olá elza,

bom, continuando a fazer exactamente como foi dito antes, ou seja, clicar numa célula da folha lotes, agora, vai colocar o comentário na folha abr, na célula que contém o valor igual ao da célula da folha lotes.

o código, passa a ser o seguinte:
'---------------------------------------------------------------------------------------
' procedure : worksheet_beforedoubleclick
' author : jrod
' date : 28/03/2013
' purpose :
'---------------------------------------------------------------------------------------
'
private sub worksheet_beforedoubleclick(byval target as range, cancel as boolean)

dim rcell as string
dim rcell1 as string
dim xpto as string
dim xpto1 as string
dim rng as range
dim vdata as long

sheets(2).select

if not intersect(target, range("d:d")) is nothing then

cancel = true
vdata = activecell.value

rcell = activecell.offset(0, 13)

if rcell = "" then
xpto = msgbox(prompt:="falta chegar:" & chr(10) & "nada", title:="falta chegar")
else
xpto = msgbox(prompt:="falta chegar:" & chr(10) & rcell, title:="falta chegar")
end if

rcell1 = activecell.offset(0, 14)

if rcell1 = "" then
xpto1 = msgbox(prompt:="falta aprovação:" & chr(10) & chr(10) & "nada", title:="falta aprovação")
else
xpto1 = msgbox(prompt:="falta aprovação:" & chr(10) & chr(10) & rcell1, title:="falta aprovação")
end if

with sheets(1).range("a1:r500")
set rng = .find(what:=vdata, _
after:=.cells(.cells.count), _
lookin:=xlvalues, _
lookat:=xlwhole, _
searchorder:=xlbyrows, _
searchdirection:=xlnext, _
matchcase:=false)

if rng.comment is nothing then rng.addcomment

rng.comment.text "falta chegar:" & chr(10) _
& rcell & chr(10) & chr(10) & "falta aprovação:" & chr(10) _
& chr(10) & rcell1 & chr(10) & chr(10) & format(now)

end with

sheets(1).select

call comments_autosize

end if

end sub


envio, de qq modo, o novo ficheiro, com a alteração.

fica bem e diz qq coisa, ok? 🙂

TesteVBA1.xlsm

[jorgerod]

olá elza,

partindo do principio de que estamos em fase de testes, fiz, em primeiro lugar, um apontamento de código, que, no final, vai buscar um outro código elaborado pela mvp dana delouis, construindo, a final, o comentário de modo a ficar sempre totalmente visível, quer o texto seja curto ou comprido.

passando mais à prática: o código que construí, está estruturado para que seja executado quando deres um duplo clique numa das células da tua coluna d.

vais ver duas mensagens previamente ao aparecimento do comentário, mas, depois, se quiseres, podes tirá-las, como é evidente… 🙂

desde que faças alguma alteração numa das células das colunas q e/ou r, correspondentes à célula da coluna d, tens que ir a esta e dar o tal duplo clique, para que o comentário seja actualizado.

bom, experimenta e diz qq coisa, ok? quanto ao resto (formatação a cores), veremos isso a seguir, ok?

envio-te então o ficheiro com os códigos que apresento abaixo:

'---------------------------------------------------------------------------------------
' procedure : worksheet_beforedoubleclick
' author : jrod
' date : 28/03/2013
' purpose :
'---------------------------------------------------------------------------------------
'
private sub worksheet_beforedoubleclick(byval target as range, cancel as boolean)

dim rcell as string
dim rcell1 as string
dim xpto as string
dim xpto1 as string
dim rng as range

if not intersect(target, range("d:d")) is nothing then

cancel = true
set rng = activecell.offset(0, 0)

rcell = activecell.offset(0, 13)

if rcell = "" then
xpto = msgbox(prompt:="falta chegar:" & chr(10) & "nada", title:="falta chegar")
else
xpto = msgbox(prompt:="falta chegar:" & chr(10) & rcell, title:="falta chegar")
end if

rcell1 = activecell.offset(0, 14)

if rcell1 = "" then
xpto1 = msgbox(prompt:="falta aprovação:" & chr(10) & chr(10) & "nada", title:="falta aprovação")
else
xpto1 = msgbox(prompt:="falta aprovação:" & chr(10) & chr(10) & rcell1, title:="falta aprovação")
end if

if rng.comment is nothing then rng.addcomment

rng.comment.text "falta chegar:" & chr(10) & rcell & chr(10) & chr(10) & "falta aprovação:" & chr(10) & chr(10) & rcell1 & chr(10) & chr(10) & format(now)

call comments_autosize

end if

end sub

sub comments_autosize()
'posted by dana delouis 2000-09-16

dim mycomments as comment
dim larea as long
for each mycomments in activesheet.comments
with mycomments
.shape.textframe.autosize = true
if .shape.width > 300 then
larea = .shape.width * .shape.height
.shape.width = 200
' an adjustment factor of 1.1 seems to work ok.
.shape.height = (larea / 200) * 1.1
end if
end with
next ' comment
end sub

TesteVBA_2013-03-28-2.xlsm

[jorgerod]

boas,

anexa aqui uma planilha de exemplo, para se poder trabalhar nela, ok?

fica bem.

[jorgerod]

albino,

no teu código estás a utilizar 2 critérios (criteria1 e criteria2), o que, na verdade, não corresponde. isto daria se quisesses filtrar, por exemplo, por apelido (criteria1) e por sexo (criteria2):

nome apelido sexo
manuel ferreira masculino
maria ferreira feminino

se escolhesses o apelido ferreira e o sexo masculino, iria dar-te o “manuel”….

manda-me, se quiseres, por mail, o teu ficheiro, para eu ver melhor o que se poderá fazer, ok?

fica bem.

[jorgerod]

albino,

sendo certo que o vou transcrever não é bem a resposta à tua pergunta, tenta ver o que terá de útil e altera o que quiseres, ok? fica bem e diz qq coisa.

cá vai:

sub escolher_data()
dim wsheetstart as worksheet
dim rfilterheads as range, acell as range
dim strcriteria as string

on error resume next

set wsheetstart = activesheet

with wsheetstart
.autofiltermode = false

strcriteria = inputbox("digite a data no formato - dd-mm-aaaa")
strcriteria = format(strcriteria, "dd-mm-yyyy")
if strcriteria = vbnullstring then
msgbox "escolheu não continuar"
application.displayalerts = false
application.displayalerts = true
.autofiltermode = false

exit sub
end if

set acell = .columns(2).find(what:=strcriteria, lookin:=xlvalues, _
lookat:=xlwhole, searchorder:=xlbyrows, searchdirection:=xlnext, _
matchcase:=false, searchformat:=false)

if acell is nothing then
.autofiltermode = false
exit sub
end if
.range("b:b").autofilter

.range("b:b").autofilter field:=1, criteria1:=strcriteria

worksheets("folha1").usedrange.copy
worksheets("folha2").range("a1").pastespecial
end with
end sub


[jorgerod]

ppv,

o teu primeiro exemplo: 7854_45_x

extrair, pela esquerda: =esquerda(a1;localizar(“_”;a1)-1), ou seja, no teu primeiro exemplo, dará o resultado 7854;

extrair pela direita: =seg.texto(a1;localizar(“_”;a1)+1;32000), ou seja, no teu primeiro exemplo, dará o resultado 45_x

o teu segundo exemplo: 456_55_t_s

extrair, pela esquerda: =esquerda(a2;localizar(“_”;a2)-1), ou seja, no teu segundo exemplo, dará o resultado 456;

extrair pela direita: =seg.texto(a2;localizar(“_”;a2)+1;32000), ou seja, no teu segundo exemplo, dará o resultado 55_t_s

etc…
(nota: 32000 é apenas um número suficientemente grande de caracteres para capturar a descrição).

créditos para o mvp je mcgimpsey – http://www.google.pt/url?sa=t&rct=j&q=je%20mcgimpsey%20&source=web&cd=1&cad=rja&ved=0cc0qfjaa&url=http%3a%2f%2fwww.mcgimpsey.com%2fexcel%2findex.html&ei=z3xlufaxdive7abgwohwcw&usg=afqjcnflot92vi4x0s3xtvl-5vogmtgd2q&bvm=bv.44158598,d.zg4

fica bem e diz qq coisa, ok?
PPV_1.jpg

[Autor]

Artigos