Saltar para o conteúdo
Consultoria · Automação · Dados · Digital

Category Archive macro

Ordenar Folhas Excel de forma Automatizada (Macro)

Pretende-se com esta macro Ordenar as Folhas de um livro de Excel de forma ascendente.

Video que mostra como fazer:

 

Código:

Option Explicit
Sub OrdenarFolhas()
‘Esta rotina coloca as folhas de Excel por ordem ascendente

Dim NomeFolhas() As String
Dim ContarFolhas As Long
Dim i As Long
Dim AntigaFolhaActiva As Object

‘Se não houver folha activa
If ActiveWorkbook Is Nothing Then Exit Sub

‘Verifica se a estrutura do livro esta protegida, se sim, não consegue ordenar e
‘devolve uma mensagem ao utilizador
If ActiveWorkbook.ProtectStructure Then
MsgBox ActiveWorkbook.Name & ” está protegida, “, vbCritical, “Não é possivel ordenar as folas. “
Exit Sub

End If

‘Verifica se o utilizador quer mesmo fazer a ordenação
If MsgBox(“Pretende ordenar as folhas deste livro de Excel?”, vbQuestion + vbOKCancel) <> vbOK Then Exit Sub

‘Desactiva o CTRL+BREAK (opção cancelar)
Application.EnableCancelKey = xlDisabled

‘Vai buscar o numero de folhas existentes
ContarFolhas = ActiveWorkbook.Sheets.Count

‘Redimensiona a Array
ReDim NomeFolhas(1 To ContarFolhas)

‘Armazena uma referência da folha activa
Set AntigaFolhaActiva = ActiveSheet

‘Preenche a array com os nomes das folhas
For i = 1 To ContarFolhas
NomeFolhas(i) = ActiveWorkbook.Sheets(i).Name
Next i

‘Coloca a array na ordem ascendente
Call BubbleSort(NomeFolhas)

‘Desactiva a actualização de ecran
Application.ScreenUpdating = False

‘Move/Ordenas as folhas
For i = 1 To ContarFolhas
ActiveWorkbook.Sheets(NomeFolhas(i)).Move _
before:=ActiveWorkbook.Sheets(i)
Next i

‘Reactiva a folha original
AntigaFolhaActiva.Activate

End Sub

Sub BubbleSort(List() As String)
‘Função criada para ordenar as folhas e que é chamada em cima

Dim primeiro, Ultimo As Long
Dim i, j As Long
Dim Temp As String

primeiro = LBound(List)
Ultimo = UBound(List)

For i = primeiro To Ultimo – 1
For j = i + 1 To Ultimo
If List(i) > List(j) Then
Temp = List(j)
List(j) = List(i)
List(i) = Temp
End If
Next j
Next i
End Sub

Enviar Emails com ficheiro comprimido como anexo quando estiver na Data Actual (VBA)

Pretende-se com este código que quando a Data de Envio for igual a data em que nos encontramos é enviado um email ao destinatário.

O código pesquisa todos os registos e envia para cada email onde a condição da data for a data actual.

ZIP_EMAIL-300x188 Enviar Emails com ficheiro comprimido como anexo quando estiver na Data Actual (VBA)
ZIP_EMAIL_2-300x183 Enviar Emails com ficheiro comprimido como anexo quando estiver na Data Actual (VBA)
ZIP_EMAIL_1-300x156 Enviar Emails com ficheiro comprimido como anexo quando estiver na Data Actual (VBA)

VBA Code/Macro:

Sub SendEmail()

Dim ws As Worksheet
Dim oApp As Object, MailApp As Object, SendMail As Object
Dim strbody As String
Dim deldate As Variant
Dim email As Variant
Dim i As Integer

Set ws = Worksheets(“sheet1”)
ws.Select

‘Set numrows = number of rows of data.
NumRows = Range(“A2”, Range(“A2”).End(xlDown)).Rows.Count

‘ Select cell A2
Range(“A2”).Select

‘Get Delivery date
lin = 2
col = 4
deldate = ws.Cells(lin, col).Value

‘Get email
lin = 2
col = 7
email = ws.Cells(lin, col).Value
‘ -1 because sheet have header
For i = 1 To NumRows – 1

If deldate = Date Then

‘Create Email
Set MailApp = CreateObject(“Outlook.Application”)
Set SendMail = MailApp.CreateItem(0)
‘Conteudo corpo da mensagem
strbody = “Your require thing has been delivered … ” & vbNewLine & vbNewLine & _
“Thanks” & vbNewLine & _
“…”

On Error Resume Next
With SendMail
.To = email ‘<- Email to send
.CC = “”
.BCC = “”
.Subject = “Your require thing has been delivered …”
.Body = strbody ‘<- Body message
.Send ‘ .Display <- Before send email to client show
‘ .send <- Send Email direct
End With
Else: Exit Sub
End If
ActiveCell.Offset(lin + i, 0).Select
deldate = ws.Cells(lin + i, 4).Value
email = ws.Cells(lin + i, 7).Value
Next

End Sub

Show Buttons
Hide Buttons