ti02,
Está dando certo seu macro. Se eu executo ele separado do meu macro ele funciona certinho!
Eu não sei porque quando eu adiciono na linha do macro principal ele nao faz o seu macro.
Segue como está o meu macro. Adicionei as linhas no vba para mudar o formato para numero e fazer F2 enter na coluna inteira (sabe como ele alterar para numero e corrigir sem ter ir no F2 enter?)
Sub Copiar()
'
' Copiar Macro
'
' Atalho do teclado: Ctrl+Shift+C
'
Sheets("PLANEJAMENTO").Select
Range("A4").Select
Selection.AutoFilter
Range("A5:t500").Select
Selection.ClearContents
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Sheets("iw37n").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWindow.ScrollRow = 1
Selection.AutoFilter
Range("A3").Select
ActiveSheet.Range("$A$1:$I$399").AutoFilter Field:=1, Criteria1:=Sheets("PLANEJAMENTO").Range("D2")
Sheets("iw37n").Select
Range("C1").Select
ActiveWindow.ScrollColumn = 1
Range("B3:B28").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("PLANEJAMENTO").Select
Range("B5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.SmallScroll Down:=-21
SendKeys "{esc}", True
'Declaramos as Variaveis
Dim sNumeros
Dim sLinsB
Dim nLinsA
'Iniciamos a Variavel com Numero 1
sNumeros = 1
'CONTAMOS OS ITENS NA COLUNA B PLAN1
sLinsB = Sheets("PLANEJAMENTO").Cells(Rows.Count, 2).End(xlUp).Row
'Loop para preencher as Linhas Col A conforme Qde Coluna B
'Inicia na Linha 5
For nLinsA = 5 To sLinsB
If Sheets("PLANEJAMENTO").Range("B" & nLinsA) = "" Then
Else
Sheets("PLANEJAMENTO").Range("A" & nLinsA) = sNumeros
sNumeros = sNumeros + 1
End If
Next
Range("J5").Select
ActiveCell.FormulaR1C1 = "'"
'pintar de cinza
If Range("a5").Value <> "" Then
Range("A5").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlThin
End With
End If
Rows("5:5").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.AutoFit
'filtra pra nao imprimir td as pagina
Range("A4:A500").Select
Selection.AutoFilter
ActiveSheet.Range("$A$4:$A$500").AutoFilter Field:=1, Criteria1:="<>"
ActiveWindow.ScrollRow = 5
Range("A5").Select
'deixa todas linhas com tamanho 12
ActiveWindow.SmallScroll Down:=-12
Rows("5:5").Select
ActiveWindow.SmallScroll Down:=123
Rows("5:143").Select
Selection.RowHeight = 12
'muda coluna B para Numero e F2 enter
Columns("B:B").Select
Selection.NumberFormat = "0"
Range("B1").Select
Dim lastRow As Long, X As Long, col As Long
col = Selection.Column
lastRow = Cells(Cells.Rows.Count, col).End(xlUp).Row
For X = 6 To lastRow
Cells(X, col).Select
mFormula = ActiveCell.FormulaLocal
ActiveCell.FormulaLocal = mFormula
Next
'inicio do macro para apagar ordem igual
Dim SalveMeuConteudo As String
Do
If ActiveCell.Offset(0, 0).Value = ActiveCell.Offset(1, 0).Value Then
SalveMeuConteudo = ActiveCell.Offset(0, 0).Value
Do
ActiveCell.Offset(1, 0).Value = ""
ActiveCell.Offset(1, 0).Select
Loop Until ActiveCell.Offset(1, 0).Value <> SalveMeuConteudo Or IsEmpty(ActiveCell.Offset(1, 0).Value)
Else
ActiveCell.Offset(1, 0).Select
End If
Loop Until IsEmpty(ActiveCell.Offset(0, 1).Value)
End Sub
Postado : 18/05/2017 8:50 am