Inserir um Calendário Completo na sua Planilha

Olá caríssimos leitores.
Sejam bem vindos mais uma vez ao meu site.
A dica de hoje será um exemplo bem prático, é claro, para aqueles leitores com conhecimento um pouco mais avançado sobre VBA. Contudo, ao final deste artigo, disponibilizarei o arquivo fonte, com todo o código utilizado e funcional, para todos poderem testar e aprender um pouco mais. Isso ajuda bastante aos iniciantes em VBA.
Vou mostrar como adicionar um calendário (do tipo folhinha de parede ou de mesa) dentro de uma planilha. Tudo isso, automaticamente, através de macro.
Esta macro, criará os grupos de meses, semanas, enfim, todos os blocos ajustados como num calendário mesmo. Com esta rotina, o leque de possibilidades de possíveis criações e adaptações é enorme. Unificar a um sistema de agenda, gerando relatórios neste formato, adaptar para imprimir apenas um mês específico, enfim. Podemos estudar bastante os fundamentos VBA.
Então vamos começar.
Acesse o ambiente VBA (ALT+F11) e adicione um módulo.
Neste módulo, escrevea o seguinte código:

Option Explicit
Sub CriarCalendario()
Dim lMonth As Long
Dim strMonth As String
Dim rStart As Range
Dim strAddress As String
Dim rCell As Range
Dim lDays As Long
Dim dDate As Date
Dim lPositionCell As Integer
Dim bEscreveData As Boolean
Dim lYear As Integer
Dim sYear As String
    'Solicita o Ano para montar o calendário
    sYear = InputBox("Informe o Ano para gerar o calendário:", "Criar Calendário", Year(Date))
    'Sai da rotina se não for informado um ano válido
    If (sYear = "" Or Not IsNumeric(sYear)) Then Exit Sub
    lYear = CInt(sYear)
    'Adiciona uma nova Planilha para criar o calendário
    Worksheets.Add
    ActiveSheet.Name = "Calendário " & lYear
    'Ocultar as linhas de grade
    ActiveWindow.DisplayGridlines = False
    'Formata as colunas
    With Cells
        .ColumnWidth = 6
        .Font.Size = 8
    End With
    'Cria o cabeçalho para os meses
    For lMonth = 1 To 12 Step 3
        Select Case lMonth
                Case 1
                    Set rStart = Range("A1")
                Case 4
                    Set rStart = Range("A9")
                Case 7
                    Set rStart = Range("A17")
                Case 10
                    Set rStart = Range("A25")
        End Select
        strMonth = MonthName(lMonth)    'Atribui o nome do mês na variável
        'Mescla, auto-preenche e alinha os blocos dos meses
        With rStart
            .Value = UCase(strMonth)
            .HorizontalAlignment = xlCenter
            .Interior.ColorIndex = 6
            .Font.Bold = True
            With .Range("A1:G1")
                .Merge
                .BorderAround LineStyle:=xlContinuous
            End With
            'Preenche o cabeçalho dos dias da semana
            For lDays = 1 To 7
                .Cells(2, lDays).Value = UCase(WeekdayName(lDays, True))
            Next lDays
            .Range("A2:G2").BorderAround LineStyle:=xlContinuous
            'Auto preenche demais meses ao lado
            .Range("A1:G2").AutoFill Destination:=.Range("A1:U2")
        End With
    Next lMonth
     'Preenche os meses com seus respectivos dias
     For lMonth = 1 To 12
        strAddress = Choose(lMonth, "A3:G8", "H3:N8", "O3:U8", _
                            "A11:G16", "H11:N16", "O11:U16", _
                            "A19:G24", "H19:N24", "O19:U24", _
                            "A27:G32", "H27:N32", "O27:U32")
        lDays = 0
        lPositionCell = 0
        bEscreveData = False
        Range(strAddress).BorderAround LineStyle:=xlContinuous
        'Adiciona os dias
        For Each rCell In Range(strAddress)
            lDays = lDays + 1
            lPositionCell = lPositionCell + 1
            dDate = DateSerial(lYear, lMonth, lDays)
            If bEscreveData = False Then
                If Weekday(dDate, vbSunday) = lPositionCell Then
                    bEscreveData = True
                Else
                    bEscreveData = False
                    lDays = 0
                End If
            End If
            If bEscreveData = True Then
                If Month(dDate) = lMonth Then   'Se for uma data válida
                    With rCell
                        .Value = dDate
                        .NumberFormat = "dd"
                    End With
                End If
            End If
        Next rCell
    Next lMonth
    'Formatação condicional para o dia de hoje.
     With Range("A1:U32")
           .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=HOJE()"
           .FormatConditions(1).Font.ColorIndex = 2
           .FormatConditions(1).Interior.ColorIndex = 11
           .HorizontalAlignment = xlCenter
    End With
End Sub

Salve e retorne para a sua planilha.
Você poderá chamar a macro CriarCalendario() adicionando um botão na planilha com ação linkada a ela ou teclando ALT+F8 e executando-a.

A rotina da macro irá solicitar o ano para gerar o calendário. Informe-o na caixa abaixo.

Clique em OK.
O resultado será como este.
Calendário gerado pela macro
Será criada uma nova planilha com o nome “Calendário AAAA”, onde AAAA é o Ano digitado.
Agora usem a criatividade para adaptá-los as suas necessidades.
Um abraço.

4 comentários em “Inserir um Calendário Completo na sua Planilha”

  1. Realmente muito bom o seu site!
    Cara, você esta de parabéns. Continue assim, e só tenderá a formar novos seguidores, e, por tabela, facilitar cada vez mais o acesso ao conhecimento.
    Grande abraço!
    FJ

    Responder
  2. ESSA MACRO ESTA COM ERRO….. OS DIAS DA SEMANA ESTAO INCORRECTOS…. O DE 2012 COMECA A UM DOMINGO E COM ESSA MACRO ESTA A COMECAR A UMA SEGUNDO 😉
    CUMPS
    CONTINUACAO DE BOM TRABALHO

    Responder

Deixe um comentário