Option Compare Database

Public Sub RassIndet()    'Routine assunti indeterminato Dirigenti & Comparto

Dim rs As DAO.Recordset
Dim ex As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim i As Integer
Dim cognome As String
Dim nome As String
Dim matricola As String
Dim contadir As Integer
Dim contacom As Integer
Dim prog As Integer


'DIRIGENTI****************************************************************************

'apre excel
Set ex = New Excel.Application
ex.Visible = True 'metti false se non vuoi vedere excel a video

'apre il file xls
Set wb = ex.Workbooks.Open("F:Asl2AutomaticProjectAssuntiCessatiMensile.xls")

'seleziona il foglio 1
Set ws = wb.Worksheets(1)
ws.Activate

'cancello i dati esistenti dalla 3 riga del foglio
    ws.Range("A5:Z65536").ClearContents
    ws.Range("A5:Z65536").ClearFormats

'SCRITTURA DATI SU EXCEL apre un recordset con la tabella da esportare
Set rs = CurrentDb.OpenRecordset("tbl_assIndetD", DAO.dbOpenDynaset)
     
    Dim mese As String   'VERIFICA PERIODO RICHIESTO E STAMPA funzione: stampaperiodo
        If rs.EOF And ws.Cells(1, 1) = "" Then
            ws.Cells(1, 1) = "inserire mese selezionato"
            Else
            mese = rs("Dataassunzione")
            mese = Mid(mese, 4, 2)
            ws.Cells(1, 1) = stampaperiodo(mese)
        End If
        
    'loop sui record
    i = 3           'scrive dalla seconda riga
    
    Do Until rs.EOF
    'aggiorna un contatore
    i = i + 1
      
    'imposta la colonna A e B per la riga = i
    cognome = rs("Cognome")
    nome = rs("Nome")
    matricola = rs("Matricola")
    contadir = contadir + 1           'conteggio dirigenti
    
    ws.Cells(i, 1) = progr + 1                                                          'progressivo
    ws.Cells(i, 2) = cognome + " " + nome + " (" + matricola + ")"                      ' cognome nome (matricola)
    If rs("DescrizioneDisciplina") = "" Then                                            'profilo professionale
        ws.Cells(i, 3) = rs("DescrizionePosizione")
        Else
        ws.Cells(i, 3) = rs("DescrizionePosizione") + " - " + rs("DescrizioneDisciplina")
    End If
    ws.Cells(i, 4) = rs("DataAssunzione")                                               'data assunzione
    ws.Cells(i, 5) = rs("DescrizioneUnitaOrg")                                          'Struttura
    ws.Cells(i, 6) = rs("DescrizioneCausaleAssunzione")
    
    progr = progr + 1
            
        'CAMBIO GRAFICA CORPO RIGHE
    ws.Range(ws.Cells(4, 1), ws.Cells(4, 7)).Select  'sorgente copia grafica
    Selection.Copy
    ws.Range(ws.Cells(i, 1), ws.Cells(i, 7)).Select    'destinazione copia grafica
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
                      
    'prossimo record
    rs.MoveNext
    Loop
    
    i = i + 1 'memorizzo l'ultima cella scritta
         
    If i = 4 Then i = 5 'SALTO UNA RIGA SE LA QUERY E' VUOTA
        
    ws.Cells(i, 1) = graficariepilogo(i, i, 1, 3)   'GRAFICA RIEPILOGO riga1, riga 2, colonna1, colonna2
    ws.Cells(i, 1) = "Personale Dirigente: " & contadir 'conteggio dirigente
    
    
'chiude recordset
rs.Close

'salva file
wb.Save

'cancella variabili oggetto
Set rs = Nothing

'COMPARTO***********************************************************************************************

'SCRITTURA DATI SU EXCEL apre un recordset con la tabella da esportare
Set rs = CurrentDb.OpenRecordset("tbl_assIndetC", DAO.dbOpenDynaset)
    
    'loop sui record
    progr = 0
    Do Until rs.EOF
    'aggiorna un contatore
    i = i + 1
    
    'imposta la colonna A e B per la riga = i
    cognome = rs("Cognome")
    nome = rs("Nome")
    matricola = rs("Matricola")
    contacom = contacom + 1           'conteggio comparto
    
    ws.Cells(i, 1) = progr + 1                                                             'progressivo
    ws.Cells(i, 2) = cognome + " " + nome + " (" + matricola + ")"                      ' cognome nome (matricola)
    If rs("DescrizioneDisciplina") = "" Then                                            'profilo professionale
        ws.Cells(i, 3) = rs("DescrizionePosizione")
        Else
        ws.Cells(i, 3) = rs("DescrizionePosizione") + " - " + rs("DescrizioneDisciplina")
    End If
    ws.Cells(i, 4) = rs("DataAssunzione")                                               'data assunzione
    ws.Cells(i, 5) = rs("DescrizioneUnitaOrg")                                          'Struttura
    ws.Cells(i, 6) = rs("DescrizioneCausaleAssunzione")
    
    progr = progr + 1
    
     'CAMBIO GRAFICA CORPO RIGHE
    ws.Range(ws.Cells(4, 1), ws.Cells(4, 7)).Select  'sorgente copia grafica
    Selection.Copy
    ws.Range(ws.Cells(i, 1), ws.Cells(i, 7)).Select    'destinazione copia grafica
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
            
    'prossimo record
    rs.MoveNext
    Loop
    
    i = i + 1                                           'grafica riepiloghi
    ws.Cells(i, 1) = graficariepilogo(i, i, 1, 3)
    ws.Cells(i, 1) = "Personale Comparto: " & contacom
    i = i + 1                                           'grafica totali
    ws.Cells(i, 1) = graficatotali(i, i, 1, 3)
    ws.Cells(i, 1) = "TOTALE GENERALE: " & (contacom + contadir)


'chiude recordset
rs.Close


'Attivo foglio successivo
Set ws = wb.Worksheets(2)
ws.Activate

'salva file
wb.Save

'chiude file
wb.Close

'esce da excel
ex.Quit

'cancella variabili oggetto
Set rs = Nothing
Set ex = Nothing
Set wb = Nothing
Set ws = Nothing

MsgBox "Generazione Excel avvenuta con successo!", vbInformation, "Generazione excel"

End Sub


-----------------------------------------------
Function graficacorpo(rig As Integer, col As Integer)
    'CAMBIO GRAFICA RIGHE
   Range("A4:G4").Select
   Selection.Copy
   Range(Cells(i, 1), Cells(i, 7)).Select
   Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
   SkipBlanks:=False, Transpose:=False
   Range(Cells(i, 1), Cells(i, 7)).RowHeight = 54.75
    'GIA COMMENTATOApplication.CutCopyMode = False
    
End Function
------------------------------------------------
Function graficariepilogo(rig1 As Integer, rig2 As Integer, col1 As Integer, col2 As Integer)
 
 Range(Cells(rig1, col1), Cells(rig2, col2)).Select

'colori
   With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .RowHeight = 35.25
    End With
    Selection.Merge

End Function
-----------------------------------------------