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 ----------------------------------------------- |