alexandrevba escreveu:Bomdia!!
Altere essa linha.
Para...
Att
viva...neste código não tem essa linha?????
Código: Selecionar todosSub Reis()
Dim sFolder As String
Dim sFile As String
Dim wbD As Workbook, wbS As Workbook
Application.ScreenUpdating = False
Set wbS = ThisWorkbook
sFolder = wbS.Path & "\"
sFile = Dir(sFolder)
Do While sFile <> ""
If sFile <> wbS.Name Then
Set wbD = Workbooks.Open(sFolder & sFile)
wbD.Sheets("Ficheiro Ramais a Executar").Range("A2:R5000").Copy
wbS.Activate
Sheets("Preenchimento").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
wbD.Close savechanges:=True
End If
sFile = Dir
Loop
Call AleVBA_Deletar
Application.ScreenUpdating = True
End Sub
Sub AleVBA_Deletar()
Dim sEntrada As String
Dim lData As Long
sEntrada = Application.InputBox("Digite a data no formato ""DD/mm/aaaa""")
lData = CLng(DateValue(sEntrada))
Worksheets("Preenchimento").Range("A1").AutoFilter Field:=14, Criteria1:=">=" & lData, Operator:=xlAnd, Criteria2:="<" & lData + 1
Dim lRows As Long
'Application.Calculation = xlCalculationManual
For lRows = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
If Cells(lRows, 1).EntireRow.Hidden = True Then Cells(lRows, 1).EntireRow.Delete
Next lRows
ActiveSheet.AutoFilterMode = False
'Application.Calculation = xlCalculationAutomatic
End Sub
é este que pretendo que pare na linha bazia em baixo e não copie o total e os textos expediente, etc..como fez no anterior código..este:
Código: Selecionar todosSub AleVBA_4207V2()
'Onde está escrito o nome -> AleVBA <-, altere para a guia que desejar
'Onde está escrito o nome -> Ficheiro Ramais a Executar<-, altere para a guia que desejar
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Set Wb = ThisWorkbook
MyDir = "C:\cme\Fic. Partilhados\Ramais\"
MyFile = Dir(MyDir & "*.xlsx")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""
Workbooks.Open (MyFile)
With Worksheets("Ficheiro Ramais a Executar")
Rws = .Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = Range(.Cells(2, 1), .Cells(Rws, 18))
Rng.Copy Wb.Worksheets("Preenchimento").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
ActiveWorkbook.Close True
End With
MyFile = Dir()
Loop
Call AleVBA_Deletar
Application.ScreenUpdating = True
End Sub
Sub AleVBA_Deletar()
Dim sEntrada As String
Dim lData As Long
sEntrada = Application.InputBox("Digite a data no formato ""DD/mm/aaaa""")
lData = CLng(DateValue(sEntrada))
Worksheets("Preenchimento").Range("A1").AutoFilter Field:=14, Criteria1:=">=" & lData, Operator:=xlAnd, Criteria2:="<" & lData + 1
Dim lRows As Long
'Application.Calculation = xlCalculationManual
For lRows = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
If Cells(lRows, 1).EntireRow.Hidden = True Then Cells(lRows, 1).EntireRow.Delete
Next lRows
ActiveSheet.AutoFilterMode = False
'Application.Calculation = xlCalculationAutomatic
End Sub
..se houver possibilidade de agilizar melhor agradeço..assim poderá ficar mais rápido
