marblesmusic

você pode entra no vba e onde estiver escrito assim VBA project, tem um ícone descrevendo assim "esta pasta de trabalho". Dê duplo clique e após a sub_function, digite na outra linha "application.fullscreen = true" Quando abrir o documento, ele entra em fullscreen! ;) Vai lá meu!

Olá Everton! Existe uma opção mais simples no Excel... Secione as colunas que você quer agrupar. Entre em Dados, em seguida, Organizar estrutura por tópicos, e por último agrupar. Vai aparecer um sinal de mais acima da coluna que você agrupou, eu acredito que seja bem mais fácil! Mas ainda posso te mandar o código se quiser! abraços

Vou tentar te ajudar... Vamos pensar numa macro assim... sub iserir_dados sheets("dados").select r = activecell.row range("A" & r).select activecell.value = conta range("B" & r).select activecell.value = banco range("C" & r).select activecell.value = veículo range("D & r).select activecell.value = preço with range("A" & r).select sheets("vazio").select range("A3").select Do if isempty(activecell) = False Then activecell.offset (1, 0 ).select End If Loop until isempty(activecell) = True range("A3").select activecell.formulaR1C1 = conta activecell.offset(0, 1).select activecell.formulaR1C1 = preço activecell.offset(0, 2).select activecell.formulaR1C1 = veículo activecell.offset(0, 3).select activecell.formulaR1C1 = banco End With Crie um botão na planilha dados com a macro, quando você selecionar uma célula válida na coluna "A"(sem se importar com qual célula, desde que tenha valores), os dados desta linha são direcionados para a planilha desejada. Você também pode mudar as ranges da linha inicial apartir dos offsets, direcionado o segundo valor por exemplo para activecell.offset(4, 6).select. O valor inicial está em A3, mas o segundo vai para D9. Com o loop ativo, se A3 estive cheia, ele assume A4 e o segundo valor D10.

Olá pessoal consegui resolver o problema! Fiz um inversão de colunas em planilhas e deu certo, talvez eu não tivesse planejado bem as referências! Também respondo dúvidas de vba através do meu e-mail uma vez por semana: marblesmusic@terra.com.br Sempre aos Sábados!

Olá! Tenh uma sugestão pra você! Pense na seguite macro, sabendo que estou criando umas variáveis beleza?Você pode criar mais uma coluna condizendo ULTIMO TOTAL? sub minha_lista range("f2").select activecell.value = saldo range("g2").select saldo = activecell.FormulaR1C1 Range("A3:A10").Select Selection.ClearContents Range("B3:B10").Select Selection.ClearContents Range("C3:C10").Select Selection.ClearContents Range("D3:D10").Select Selection.ClearContents Range("E3:E10").Select Selection.ClearContents Range("D1").Select Selection.ClearContents End Sub No caso , acélula G2 não recerá fórmula, enquanto que f2 continuará com a fórmula. Em G1 o título "último saldo" Pelo menos tentei!

Olá melaine! deixe me ver se eu entendi o que você quer... ao executar uma macro, você enxerga a macro em excução (as etapas acontecendo de maneira rápida, mas visual). Para que isso não ocorra, acrescente isso no início das suas macros... Exemplo: Sub Minha_macro application.screenupdating = false 'esse é o comando' end sub Ao utilizar o application.screenupdating = false, a macro pula do início para o final sem intervalos.

Você pode tentar criar uma cópia da planilha quando estiver completa, pode ser uma solução útil. E fazer iserção de códigos que limpem as células desejadas de modo simples. Vou citar um exemplo: sub compilar_dados() activesheet.copy after :=sheets(3) sheets("plan1").select range("a1").select activecell.value.delete range("e4").select activecell.value.delete range("f2").select end sub

Estou desenvolvendo uma planilha que faz o seguinte: ao inserir dados em linhas, o loop funciona bem. O problema é quando tento tranferir os dados de duas planilhas para uma terceira que mais parece um formulário. Na primeira planilha os dados provém de uma única linha e da seguda planilha, 4 linhas com infomações referentes à linha da primeira planilha. Como fazer com que o programa busque os dados a partir da quinta linha da segunda planilha no que se refere à segunda linha da primeira planilha? Sabendo que, o valor de A1 da primeira planilha por exemplo, é o mesmo valor de A1,A2,A3 e A4 da segunda. Na terceira, A1 da primeira planilha é o título, enquanto que as demais preenchen linhas específicas da planilha. O código é é este aqui... complexo ou não? Pra mim é desafio! Ainda não consegui! Demarquei o ponto em que acredito estar o erro! Sub WordArt39_Clique() Application.ScreenUpdating = False Sheets("I.S").Visible = True Sheets("Folha de elementos").Visible = True Sheets("Compl. elementos").Visible = True ri = ActiveCell.Row Selection.End(xlDown).Select rf = ActiveCell.Row rqt = rf - ri + 1 FQT = Int(rqt / 4) + 1 If FQT > 10000 Then FQT = 1 RR = ri - 1 F = 0 Range("E" & r1 + 1).Select numele = ActiveCell.Value Range("C" & r1 + 1).Select plata = ActiveCell.Value With Range("e" & ri + 1).Select Cells.Find(What:=numele, After:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False).Activate Do While F < FQT Sheets("Elementos").Select F = F + 1 V = 0 For I = 1 To 4 If I = 1 Then Range("F" & RR + I).Select nomele = ActiveCell.FormulaR1C1 Range("C" & RR + I).Select PLT = ActiveCell.FormulaR1C1 Range("I" & RR + I).Select LCL = ActiveCell.FormulaR1C1 Range("D" & RR + I).Select modelo = ActiveCell.FormulaR1C1 Range("E" & RR + I).Select numele = ActiveCell.FormulaR1C1 Range("G" & RR + I).Select baop = ActiveCell.FormulaR1C1 Range("J" & RR + I).Select tempo = ActiveCell.FormulaR1C1 Range("L" & RR + I).Select hest = ActiveCell.FormulaR1C1 Range("M" & RR + I).Select dtest = ActiveCell.FormulaR1C1 Sheets("I.S").Select Range("B94").Select escr = ActiveCell.FormulaR1C1 Range("B94").Select ct1 = ActiveCell.Value Range("X94").Select ct2 = ActiveCell.Value Range("AY8").Select sup1 = ActiveCell.Value Range("BS8").Select sup2 = ActiveCell.Value Range("AT94").Select eng1 = ActiveCell.Value Range("BP94").Select eng2 = ActiveCell.Value Sheets("Compl. elementos").Select Range("A" & RR + I).Select numele = ActiveCell.FormulaR1C1 If F > 1 Then If numele <> numele1 Then FQT = FQT - 1 GoTo retry6 End If End If Sheets("Folha de elementos").Visible = True Sheets("Folha de elementos").Select Sheets("Folha de elementos").Copy After:=Sheets(7 + F - 1) Sheets("Folha de elementos").Visible = False If baop <> "O" Then ActiveSheet.Shapes("Oval 2").Select Selection.ShapeRange.Fill.Visible = msoTrue Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8 ActiveSheet.Shapes("Oval 4").Select Selection.ShapeRange.Fill.Visible = msoFalse Else If baop = "O" Then ActiveSheet.Shapes("Oval 4").Select Selection.ShapeRange.Fill.Visible = msoTrue Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8 ActiveSheet.Shapes("Oval 2").Select Selection.ShapeRange.Fill.Visible = msoFalse End If End If Range("S43").Select If LCL = "C4" Then ActiveSheet.Shapes("Rectangle 91").Select Selection.ShapeRange.Fill.Visible = msoTrue End If If LCL = "E4" Then ActiveSheet.Shapes("Rectangle 83").Select Selection.ShapeRange.Fill.Visible = msoTrue End If If LCL = "C3" Then ActiveSheet.Shapes("Rectangle 90").Select Selection.ShapeRange.Fill.Visible = msoTrue End If If LCL = "E3" Then ActiveSheet.Shapes("Rectangle 82").Select Selection.ShapeRange.Fill.Visible = msoTrue End If If LCL = "C2" Then ActiveSheet.Shapes("Rectangle 89").Select Selection.ShapeRange.Fill.Visible = msoTrue End If If LCL = "E2" Then ActiveSheet.Shapes("Rectangle 81").Select Selection.ShapeRange.Fill.Visible = msoTrue End If If LCL = "E1" Then ActiveSheet.Shapes("Rectangle 80").Select Selection.ShapeRange.Fill.Visible = msoTrue End If If LCL = "C1" Then ActiveSheet.Shapes("Rectangle 84").Select Selection.ShapeRange.Fill.Visible = msoTrue End If If LCL = "D1" Then ActiveSheet.Shapes("Rectangle 85").Select Selection.ShapeRange.Fill.Visible = msoTrue End If If LCL = "D2" Then ActiveSheet.Shapes("Rectangle 86").Select Selection.ShapeRange.Fill.Visible = msoTrue End If If LCL = "D3" Then ActiveSheet.Shapes("Rectangle 87").Select Selection.ShapeRange.Fill.Visible = msoTrue End If If LCL = "D4" Then ActiveSheet.Shapes("Rectangle 88").Select Selection.ShapeRange.Fill.Visible = msoTrue End If Range("X12").Select ActiveCell.FormulaR1C1 = PLT Range("z12").Select ActiveCell.FormulaR1C1 = modelo Range("ae12").Select ActiveCell.FormulaR1C1 = numele Range("b14").Select ActiveCell.FormulaR1C1 = nomele Range("ac13").Select ActiveCell.FormulaR1C1 = escr Range("e50").Select ActiveCell.FormulaR1C1 = ct1 Range("h50").Select ActiveCell.FormulaR1C1 = sup1 Range("m50").Select ActiveCell.FormulaR1C1 = eng1 Range("e52").Select ActiveCell.FormulaR1C1 = ct2 Range("h52").Select ActiveCell.FormulaR1C1 = sup2 Range("m52").Select ActiveCell.FormulaR1C1 = eng2 End If ------------------------------------------------------------------Sei que o erro pode estar aqui, falta alguma coisa?--------- numele1 = numele Sheets("Compl. elementos").Select Range("A" & RR + I).Select numele = ActiveCell.FormulaR1C1 Range("J" & RR + I).Select dtrev = ActiveCell.FormulaR1C1 Range("K" & RR + I).Select alt = ActiveCell.FormulaR1C1 Range("L" & RR + I).Select nrev = ActiveCell.FormulaR1C1 Range("M" & RR + I).Select SIMB = ActiveCell.FormulaR1C1 If I > 1 Then If numele <> numele1 Then GoTo retry6 End If Range("j" & RR + I).Select dtrev = ActiveCell.FormulaR1C1 Range("L" & RR + I).Select nrev = ActiveCell.FormulaR1C1 Range("K" & RR + I).Select alt = ActiveCell.FormulaR1C1 Range("B" & RR + I).Select seq = ActiveCell.FormulaR1C1 Range("C" & RR + I).Select ppri = ActiveCell.FormulaR1C1 Range("D" & RR + I).Select pcha = ActiveCell.FormulaR1C1 Range("E" & RR + I).Select raz = ActiveCell.FormulaR1C1 Range("F" & RR + I).Select dtoque = ActiveCell.FormulaR1C1 Range("G" & RR + I).Select hoque = ActiveCell.FormulaR1C1 Range("H" & RR + I).Select dtqua = ActiveCell.FormulaR1C1 Range("I" & RR + I).Select hqua = ActiveCell.FormulaR1C1 '------------------------------------------------------------------------------------------------------------ 'If ppri = "" Then GoTo RETRY5 Sheets("Folha de elementos (" & F + 1 & ")").Select If V < 4 Then Application.GoTo Reference:="R44" & "C" & 29 + V ActiveCell.FormulaR1C1 = hest Application.GoTo Reference:="R50" & "C" & 29 + V ActiveCell.FormulaR1C1 = dtest Application.GoTo Reference:="R47" & "C" & 29 + V ActiveCell.FormulaR1C1 = tempo End If If V < 3 Then Range("Z" & 53 + V).Select ActiveCell.FormulaR1C1 = dtrev Range("AB" & 53 + V).Select ActiveCell.FormulaR1C1 = nrev Range("AC" & 53 + V).Select ActiveCell.FormulaR1C1 = alt End If V = V + 1 '----------------------------------------------- texto distribuido passo principal TXT = ppri If I = 1 Then frf = 20 If I = 2 Then frf = 26 If I = 3 Then frf = 32 If I = 4 Then frf = 38 Range("U" & frf).Select ActiveCell.FormulaR1C1 = seq '----------------------------------------------------------------------- simbolo If SIMB = "S" Then ActiveSheet.Shapes("AutoShape 138").Select Selection.Copy Range("s" & frf + 1).Select ActiveSheet.Paste End If If SIMB = "C" Then ActiveSheet.Shapes("Group 135").Select Selection.Copy Range("S" & frf + 1).Select ActiveSheet.Paste End If If SIMB = "que" Then ActiveSheet.Shapes("AutoShape 134").Select Selection.Copy Range("S" & frf + 1).Select ActiveSheet.Paste Selection.ShapeRange.IncrementLeft -48# Selection.ShapeRange.IncrementTop -30# End If If SIMB = "O" Then ActiveSheet.Shapes("Rectangle 139").Select Selection.Copy Range("S" & frf + 1).Select ActiveSheet.Paste Selection.ShapeRange.IncrementLeft -21# Selection.ShapeRange.IncrementTop -27# Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8 Selection.ShapeRange.Fill.Visible = msoTrue Selection.ShapeRange.Fill.Solid End If If SIMB = "SQ" Then ActiveSheet.Shapes("AutoShape 138").Select Selection.Copy Range("s" & frf + 1).Select ActiveSheet.Paste ActiveSheet.Shapes("AutoShape 134").Select Selection.Copy Range("S" & frf + 1).Select ActiveSheet.Paste Selection.ShapeRange.IncrementLeft -48# Selection.ShapeRange.IncrementTop -30# End If If SIMB = "SC" Then ActiveSheet.Shapes("AutoShape 138").Select Selection.Copy Range("s" & frf + 1).Select ActiveSheet.Paste ActiveSheet.Shapes("Group 135").Select Selection.Copy Range("S" & frf + 1).Select ActiveSheet.Paste End If If SIMB = "SO" Then ActiveSheet.Shapes("AutoShape 138").Select Selection.Copy Range("s" & frf + 1).Select ActiveSheet.Paste ActiveSheet.Shapes("Rectangle 139").Select Selection.Copy Range("S" & frf + 1).Select ActiveSheet.Paste Selection.ShapeRange.IncrementLeft -21# Selection.ShapeRange.IncrementTop -27# Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8 Selection.ShapeRange.Fill.Visible = msoTrue Selection.ShapeRange.Fill.Solid End If If SIMB = "QC" Then ActiveSheet.Shapes("AutoShape 134").Select Selection.Copy Range("S" & frf + 1).Select ActiveSheet.Paste Selection.ShapeRange.IncrementLeft -48# Selection.ShapeRange.IncrementTop -30# ActiveSheet.Shapes("Group 142").Select Selection.Copy Range("S" & frf + 1).Select ActiveSheet.Paste End If If SIMB = "QO" Then ActiveSheet.Shapes("AutoShape 134").Select Selection.Copy Range("S" & frf + 1).Select ActiveSheet.Paste Selection.ShapeRange.IncrementLeft -48# Selection.ShapeRange.IncrementTop -30# ActiveSheet.Shapes("Rectangle 139").Select Selection.Copy Range("S" & frf + 1).Select ActiveSheet.Paste Selection.ShapeRange.IncrementLeft -21# Selection.ShapeRange.IncrementTop -27# Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8 Selection.ShapeRange.Fill.Visible = msoTrue Selection.ShapeRange.Fill.Solid End If If SIMB = "CO" Then ActiveSheet.Shapes("Group 135").Select Selection.Copy Range("S" & frf + 1).Select ActiveSheet.Paste ActiveSheet.Shapes("Rectangle 139").Select Selection.Copy Range("S" & frf + 1).Select ActiveSheet.Paste Selection.ShapeRange.IncrementLeft -21# Selection.ShapeRange.IncrementTop -27# Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8 Selection.ShapeRange.Fill.Visible = msoTrue Selection.ShapeRange.Fill.Solid End If '-------------------------------------------------------------------------- v3 = Len(TXT) T = 40 't é a quantidade de caracter máxima por linha If v3 < T Then Range("v" & frf).Select ActiveCell.FormulaR1C1 = ppri GoTo RETRY3 End If ct = 0 For Z = 1 To 500 j = Z l = 1 Do For y = j To Z + T TXT1 = Mid(TXT, y, 1) If TXT1 = " " Then vi = y End If TXT1 = Mid(TXT, j, y) Next x = vi - j If x > 0 Then If v3 - j > T Then TXTF = Mid(TXT, j, vi - j) Else TXTF = Mid(TXT, j, v3) Range("v" & frf + ct).Select ActiveCell.Formula = TXTF j = vi + 1 Z = vi + 1 l = l + 1 ct = ct + 1 fr1 = ActiveCell.Row GoTo RETRY3 End If Else Range("v" & frf + ct).Select ActiveCell.Formula = TXT1 GoTo RETRY3 End If Range("v" & frf + ct).Select ActiveCell.Formula = TXTF j = vi + 1 Z = vi + 1 l = l + 1 ct = ct + 1 Loop Next RETRY3: '----------------------------------------------- texto distribuido ponto chave TXT = pcha If I = 1 Then frf = 20 If I = 2 Then frf = 26 If I = 3 Then frf = 32 If I = 4 Then frf = 38 v3 = Len(TXT) T = 25 't é a quantidade de caracter máxima por linha If v3 < T Then Range("aa" & frf).Select ActiveCell.FormulaR1C1 = pcha GoTo retry31 End If ct = 0 For Z = 1 To 500 j = Z l = 1 Do For y = j To Z + T TXT1 = Mid(TXT, y, 1) If TXT1 = " " Then vi = y End If TXT1 = Mid(TXT, j, y) Next x = vi - j If x > 0 Then If v3 - j > T Then TXTF = Mid(TXT, j, vi - j) Else TXTF = Mid(TXT, j, v3) Range("aa" & frf + ct).Select ActiveCell.Formula = TXTF j = vi + 1 Z = vi + 1 l = l + 1 ct = ct + 1 fr1 = ActiveCell.Row GoTo retry31 End If Else Range("AA" & frf + ct).Select ActiveCell.Formula = TXT1 GoTo retry31 End If Range("aa" & frf + ct).Select ActiveCell.Formula = TXTF j = vi + 1 Z = vi + 1 l = l + 1 ct = ct + 1 Loop Next retry31: '----------------------------------------------- texto distribuido razao TXT = raz If I = 1 Then frf = 20 If I = 2 Then frf = 26 If I = 3 Then frf = 32 If I = 4 Then frf = 38 v3 = Len(TXT) T = 28 't é a quantidade de caracter máxima por linha If v3 < T Then Range("ad" & frf).Select ActiveCell.FormulaR1C1 = raz GoTo retry32 End If ct = 0 For Z = 1 To 500 j = Z l = 1 Do For y = j To Z + T TXT1 = Mid(TXT, y, 1) If TXT1 = " " Then vi = y End If TXT1 = Mid(TXT, j, y) Next x = vi - j If x > 0 Then If v3 - j > T Then TXTF = Mid(TXT, j, vi - j) Else TXTF = Mid(TXT, j, v3) Range("ad" & frf + ct).Select ActiveCell.Formula = TXTF j = vi + 1 Z = vi + 1 l = l + 1 ct = ct + 1 fr1 = ActiveCell.Row GoTo retry32 End If Else Range("ad" & frf + ct).Select ActiveCell.Formula = TXT1 GoTo retry32 End If Range("ad" & frf + ct).Select ActiveCell.Formula = TXTF j = vi + 1 Z = vi + 1 l = l + 1 ct = ct + 1 Loop Next retry32: '----------------------------------------------- texto distribuido historico seguranca TXT = hoque If I = 1 Then frf = 61 If I = 2 Then frf = 79 If I = 3 Then frf = 97 If I = 4 Then frf = 113 Range("b" & frf).Select ActiveCell.FormulaR1C1 = dtoque v3 = Len(TXT) T = 68 't é a quantidade de caracter máxima por linha If v3 < T Then Range("e" & frf).Select ActiveCell.FormulaR1C1 = hoque GoTo retry33 End If ct = 0 For Z = 1 To 1000 j = Z l = 1 Do For y = j To Z + T TXT1 = Mid(TXT, y, 1) If TXT1 = " " Then vi = y End If TXT1 = Mid(TXT, j, y) Next x = vi - j If x > 0 Then If v3 - j > T Then TXTF = Mid(TXT, j, vi - j) Else TXTF = Mid(TXT, j, v3) Range("e" & frf + ct).Select ActiveCell.Formula = TXTF j = vi + 1 Z = vi + 1 l = l + 1 ct = ct + 1 fr1 = ActiveCell.Row GoTo retry33 End If Else Range("E" & frf + ct).Select ActiveCell.Formula = TXT1 GoTo retry33 End If Range("e" & frf + ct).Select ActiveCell.Formula = TXTF j = vi + 1 Z = vi + 1 l = l + 1 ct = ct + 2 Loop Next retry33: '----------------------------------------------- texto distribuido historico qualidade TXT = hqua If I = 1 Then frf = 61 If I = 2 Then frf = 79 If I = 3 Then frf = 97 If I = 4 Then frf = 113 Range("w" & frf).Select ActiveCell.FormulaR1C1 = dtqua v3 = Len(TXT) T = 68 't é a quantidade de caracter máxima por linha If v3 < T Then Range("y" & frf).Select ActiveCell.FormulaR1C1 = hqua GoTo retry34 End If ct = 0 For Z = 1 To 1000 j = Z l = 1 Do For y = j To Z + T TXT1 = Mid(TXT, y, 1) If TXT1 = " " Then vi = y End If TXT1 = Mid(TXT, j, y) Next x = vi - j If x > 0 Then If v3 - j > T Then TXTF = Mid(TXT, j, vi - j) Else TXTF = Mid(TXT, j, v3) Range("y" & frf + ct).Select ActiveCell.Formula = TXTF j = vi + 1 Z = vi + 1 l = l + 1 ct = ct + 1 fr1 = ActiveCell.Row GoTo retry34 End If Else Range("Y" & frf + ct).Select ActiveCell.Formula = TXT1 GoTo retry34 End If Range("y" & frf + ct).Select ActiveCell.Formula = TXTF j = vi + 1 Z = vi + 1 l = l + 1 ct = ct + 2 Loop Next retry34: RETRY5: Next RR = RR + I - 1 Range("a1").Select Loop retry6: A = Array(8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8) For I = 2 To FQT A(I) = 8 + I - 1 Next Sheets("Elementos").Select ' ActiveSheet.ShowAllData RETRY1: Sheets("Compl. elementos").Visible = False Sheets("I.S").Visible = False Range("a7").Select End With End Sub