Davi Spinetti

1 hora atrás, osvaldomp disse:

 

Experimente:

 

Sub ExcluiLinhas()
 Application.ScreenUpdating = False
  Range("K11:K" & Cells(Rows.Count, 2).End(3).Row).Value = "=IF(D11=""-"",1,0)"
  Range("A11:K" & Cells(Rows.Count, 2).End(3).Row).AutoFilter 11, 1
  Range("A12:K" & Cells(Rows.Count, 2).End(3).Row).EntireRow.Delete
  ActiveSheet.AutoFilterMode = False
  Columns(11).Value = ""
 Application.ScreenUpdating = True
End Sub

 

Boa Tarde, Primeiramente obrigado, a macro funcionou em parte ela removeu tudo da certinho da coluna D porém da coluna J que tb tem "-" ela não removeu

Boa Noite

Achei essa macro que faz exatamente o que eu preciso, porém qd chega a uma determinada quantidade de linha ela parra, sem apresentar erro apenas encerra e diz que foi concluído.

Sub Executa()
    MsgBox "Foram excluídas " & ExcluiLinhasPorCriterio(1, 200, 6, "London") & " linhas"
End Sub

Function ExcluiLinhasPorCriterio(ByVal linhaInicial As Integer, ByVal linhaFinal As Integer, ByVal colunaCriterio As Integer, ByVal criterio As String) As Integer
    Dim linhasExcluidas As Integer
    Dim i As Integer
    linhasExcluidas = 0
    With ActiveSheet
        i = linhaInicial
        While i < linhaFinal
            If CStr(.Cells(i, 4).Value) = "-" Then
                .Rows(i).Delete
                linhasExcluidas = linhasExcluidas + 1
            Else
                i = i + 1
            End If
        Wend
    End With
    ExcluiLinhasPorCriterio = linhasExcluidas

Boa noite,
Preciso excluir da planilha em anexo as linhas que contiverem os valores " - " das células D e J e jogar o conteúdo ( se existir) para a cima (como o próprio Excel faz) confesso que sou leigo no assunto, achei essa macro que supostamente faz o que eu preciso, porém chega a um determinado valor ela da Erro e para, se alguém puder me ajudar agradeço.  

Sub limpar_relatorio()

' Excluir Inativos
Application.ScreenUpdating = False
Range("D:J").Select
Dim w As Range
Dim faixa As Range

Set faixa = Selection
Dim criterio As String
criterio = "-"
For Each w In faixa
If InStr(1, w.Value2, criterio) <> 0 Then
w.Activate
ActiveCell.EntireRow.Delete
Call Excluir_Inativos
Exit Sub
End If
Next

Application.ScreenUpdating = True
End Sub

BALIZAMENTO.xlsx

Boa noite, desculpe não sou nenhum Expert no assunto, porém encontrei esse código na internet e ele faz exatamente o que eu preciso, ele um loop copiando os dados de varias planilhas (abas) de um mesmo arquivo, entretanto preciso que ele copie apenas os dados da primeira planilha ( aba "CONSOLIDADO") de cada arquivo e cole em formato especial "valores" e despreze as outras abas, se alguém puder me ajudar ficarei muito agradecido. 

'UnificarPlanilhas Macro
Sub lsUnificarPlanilhas()
On Error GoTo Sair

Dim lUltimaColunaAtiva As Long
Dim lUltimaLinhaAtiva As Long
Dim lRng As Range
Dim sPath As String
Dim fName As String
Dim lNomeWB As String
Dim lIPlan As Integer
Dim lUltimaLinhaPlanDestino As Long

PlanilhaDestino = ThisWorkbook.Name

sPath = Localizar_Caminho

sName = Dir(sPath & "\*.xl*")

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Do While sName <> ""
fName = sPath & "\" & sName
Workbooks.Open Filename:=fName, UpdateLinks:=False

lNomeWB = ActiveWorkbook.Name

For lIPlan = 1 To ActiveWorkbook.Sheets.Count
Workbooks(lNomeWB).Worksheets(lIPlan).Activate

lUltimaLinhaAtiva = Cells(Rows.Count, 1).End(xlUp).Row
lUltimaColunaAtiva = ActiveSheet.Cells(1, 5000).End(xlToLeft).Column

Set lRng = Range(Cells(1, lUltimaColunaAtiva).Address)

Range("A" & 1 & ":" & gfLetraColuna(lRng) & lUltimaLinhaAtiva).Select
Selection.Copy

Workbooks(PlanilhaDestino).Worksheets(1).Activate

lUltimaLinhaPlanDestino = Cells(Rows.Count, 1).End(xlUp).Row

If lUltimaLinhaPlanDestino > 1 Then
lUltimaLinhaPlanDestino = Cells(Rows.Count, 1).End(xlUp).Row + 1
End If

Range("A" & lUltimaLinhaPlanDestino).Select

ActiveSheet.Paste
Application.CutCopyMode = False
Next lIPlan

Workbooks(lNomeWB).Close SaveChanges:=False
sName = Dir()
Loop

MsgBox "Planilhas unificadas!"

Sair:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

Function gfLetraColuna(ByVal rng As Range) As String
Dim lTexto() As String

lTexto = Split(rng.Address, "$")

gfLetraColuna = lTexto(1)
End Function

Public Function Localizar_Caminho() As String

Dim strCaminho As String

With Application.FileDialog(msoFileDialogFolderPicker)

'Permitir mais de uma pasta
.AllowMultiSelect = False

'Mostrar janela
.Show

If .SelectedItems.Count > 0 Then
strCaminho = .SelectedItems(1)
End If

End With

'Atribuir caminho a variável
Localizar_Caminho = strCaminho

End Function