Douglas Freire - MADMAX

Um Modulo que exporta dados de uma Tabela Access para uma planilha excel. Douglas Freire  - MADMAX **********************CÓDIGO***************************  Option Compare Database Private Sub Excel_Click() Dim db As DAO.Database Dim rs As DAO.Recordset Dim PathFt As String Dim ss As String Dim Sessao, Folha, iRow, i PathFt = DFirst("PathEquip", "Conf_Sist") ss = "SELECT * FROM TGI_Identificacao" Set db = CurrentDb() Set rs = db.OpenRecordset(ss) Set Sessao = CreateObject("Excel.Application") Sessao.Visible = False Sessao.Workbooks.Open FileName:="z:\\Materiais.xls" Set Folha = Sessao.Worksheets(1) iRow = 4 'inicio da primeira linha If Not rs.EOF Then Do Until rs.EOF For i = 0 To rs.Fields.Count - 1 Folha.Cells(iRow, i + 1).Value = rs.Fields(i) Next iRow = iRow + 1 rs.MoveNext Loop Sessao.Visible = True End If Dim col, lin, ncol, nlin, st, letra lin = 4 ncol = 22 nlin = 10 With Folha For i = 1 To ncol If i = 1 Then col = "F" ElseIf i = 2 Then col = "G" ElseIf i = 3 Then col = "H" ElseIf i = 4 Then col = "I" ElseIf i = 5 Then col = "J" ElseIf i = 6 Then col = "K" ElseIf i = 7 Then col = "L" ElseIf i = 8 Then col = "M" ElseIf i = 9 Then col = "N" ElseIf i = 10 Then col = "O" ElseIf i = 11 Then col = "P" ElseIf i = 12 Then col = "Q" End If For st = lin - 1 To nlin + 2 If .Range("" & col & (st + 1) & "") <> "" Then .Range("" & col & (st + 1) & "").Interior.ColorIndex = 3 .Range("" & col & (st + 1) & "").Interior.Pattern = xlSolid .Range("" & col & (st + 1) & "").Font.ColorIndex = 3 End If Next Next End With With Folha .Columns("A:A").ColumnWidth = 9 .Columns("B:B").ColumnWidth = 32 .Columns("C:C").ColumnWidth = 12 .Columns("D").ColumnWidth = 6 .Columns("E:E").ColumnWidth = 10 .Columns("F:Q").ColumnWidth = 2.2 .Columns("F:Q").HorizontalAlignment = xlCenter .Range("A3") = "Nº CPqD" .Range("B3") = "Tipo Equipamento" .Range("C3") = "Modelo" .Range("D3") = "Dept" .Range("E3") = "Labor" .Range("A2:Q2").Merge '.Range("A2") = "Pesquisa de " & Format(DateSerial(Year(Me.dtini), Month(Me.dtini), 1), MMMM/yy") & " até " _ '& Format(DateSerial(Year(Me.dtini), Month(Me.dtini) + (Me.QtdMeses - 1), 1), "MMMM/yy") _ '& " (Equipamentos - Mes/Dia)" .Columns("F:Q").NumberFormat = Format("DD") .Range("A3:Q3").HorizontalAlignment = xlCenter .Range("A3:Q3").VerticalAlignment = xlCenter .Range("F3:Q3").Orientation = 90 .Range("A3:Q3").Font.Bold = True '.Range("F3") = Format(DateSerial(Year(Me.dtini), Month(Me.dtini), 1), "mmm") '.Range("G3") = Format(DateSerial(Year(Me.dtini), Month(Me.dtini) + 1, 1), "mmm") '.Range("H3") = Format(DateSerial(Year(Me.dtini), Month(Me.dtini) + 2, 1), "mmm") '.Range("I3") = Format(DateSerial(Year(Me.dtini), Month(Me.dtini) + 3, 1), "mmm") '.Range("J3") = Format(DateSerial(Year(Me.dtini), Month(Me.dtini) + 4, 1), "mmm") '.Range("K3") = Format(DateSerial(Year(Me.dtini), Month(Me.dtini) + 5, 1), "mmm") '.Range("L3") = Format(DateSerial(Year(Me.dtini), Month(Me.dtini) + 6, 1), "mmm") '.Range("M3") = Format(DateSerial(Year(Me.dtini), Month(Me.dtini) + 7, 1), "mmm") '.Range("N3") = Format(DateSerial(Year(Me.dtini), Month(Me.dtini) + 8, 1), "mmm") '.Range("O3") = Format(DateSerial(Year(Me.dtini), Month(Me.dtini) + 9, 1), "mmm") '.Range("P3") = Format(DateSerial(Year(Me.dtini), Month(Me.dtini) + 10, 1), "mmm") '.Range("Q3") = Format(DateSerial(Year(Me.dtini), Month(Me.dtini) + 11, 1), "mmm") End With iRow = iRow - 1 With Folha .Range("A1:Q" & iRow & "").Font.Name = "Arial" .Range("A3:Q" & iRow & "").Font.Size = 8 .Range("A3:Q1").Interior.ColorIndex = 15 .Range("A3:Q1").Interior.Pattern = xlSolid .Range("A3:Q1").HorizontalAlignment = xlCenter .Range("A3:Q1").VerticalAlignment = xlCenter .Range("A3:Q1").Font.Bold = True .Range("A3:Q1").Font.ColorIndex = 2 .Range("A:A").Font.Bold = True .Columns("A:A").HorizontalAlignment = xlCenter .Range("A1:Q1").Merge .Range("A1:Q1").Font.Size = 14 .Range("A1:Q1").WrapText = True .Range("A1:Q1").MergeCells = True .Rows("1:1").RowHeight = 30 '.Range("A1") = "RCE - MONITORAMENTO DE " & Me.RtMonitor.Caption .Range("A3:Q" & iRow & "").Borders(xlInsideVertical).LineStyle = xlContinuous .Range("A3:Q" & iRow & "").Borders(xlInsideVertical).Weight = xlMedium .Range("A3:Q" & iRow & "").Borders(xlInsideVertical).ColorIndex = 16 .Range("A3:Q" & iRow & "").Borders(xlInsideHorizontal).LineStyle = xlContinuous .Range("A3:Q" & iRow & "").Borders(xlInsideHorizontal).Weight = xlThin .Range("A3:Q" & iRow & "").Borders(xlInsideHorizontal).ColorIndex = 16 .Range("A1:Q" & iRow & "").Borders(xlEdgeLeft).LineStyle = xlDouble .Range("A1:Q" & iRow & "").Borders(xlEdgeLeft).Weight = xlThick .Range("A1:Q" & iRow & "").Borders(xlEdgeLeft).ColorIndex = 16 .Range("A1:Q" & iRow & "").Borders(xlEdgeTop).LineStyle = xlDouble .Range("A1:Q" & iRow & "").Borders(xlEdgeTop).Weight = xlThick .Range("A1:Q" & iRow & "").Borders(xlEdgeTop).ColorIndex = 16 .Range("A1:Q" & iRow & "").Borders(xlEdgeBottom).LineStyle = xlDouble .Range("A1:Q" & iRow & "").Borders(xlEdgeBottom).Weight = xlThick .Range("A1:Q" & iRow & "").Borders(xlEdgeBottom).ColorIndex = 16 .Range("A1:Q" & iRow & "").Borders(xlEdgeRight).LineStyle = xlDouble .Range("A1:Q" & iRow & "").Borders(xlEdgeRight).Weight = xlThick .Range("A1:Q" & iRow & "").Borders(xlEdgeRight).ColorIndex = 16 .Range("A3:Q3").Borders(xlEdgeTop).LineStyle = xlDouble .Range("A3:Q3").Borders(xlEdgeTop).Weight = xlThick .Range("A3:Q3").Borders(xlEdgeTop).ColorIndex = 16 .Range("A3:Q3").Borders(xlEdgeBottom).LineStyle = xlDouble .Range("A3:Q3").Borders(xlEdgeBottom).Weight = xlThick .Range("A3:Q3").Borders(xlEdgeBottom).ColorIndex = 16 .Range("F3:Q" & iRow & "").Font.Bold = True iRow = iRow + 1 .Range("A" & iRow & "") = "Fim da Consulta - Emitida em " & Date .Range("A" & iRow & "").HorizontalAlignment = xlLeft .Range("A" & iRow & "").Font.ColorIndex = 3 .Range("A" & iRow & "").Font.Name = "Arial" .Range("A" & iRow & "").Font.Size = 8 .Range("C" & iRow & "").Select iRow = iRow + 1 .Rows("" & iRow & ":65536").EntireRow.Hidden = True .Columns("S:IV").EntireColumn.Hidden = True .Columns("R:R").ColumnWidth = 0.2 .SetBackgroundPicture FileName:=PathFt & "\\fundtext.jpg" .Range("A3:Q37").Sort Key1:=Range("E4"), Order1:=xlAscending End With Set Folha = Nothing Set Sessao = Nothing rs.Close db.Close Set rs = Nothing Set db = Nothing End Sub

Quebra-Linha

Colaborador..: Douglas Freire
Categoria(s).: Access;
Data.........: 16/05/2005 20:35:58
Visualizado..: 7964 vezes
Fonte........: FORRUM ACCESS