exportar a excel con nombre específico de hoja
Publicado por carlos (70 intervenciones) el 11/05/2024 22:12:55
saludos nuevamente, estaba retomando un código que construye una tabla y la exporta pero que me está dando un nombre que toma del código, en este caso, NombrePrograma, y necesito que esa hora se nombre EXPORTA porque va a ser importada en otra aplicación que ya está preparada para eso, llevo horas intentando y no lo encuentro, Dios mío, este es el código
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
Private Sub ExpProgEmit_Click()
Dim rstNombrePrograma As DAO.Recordset, _
rstFechaPrograma As DAO.Recordset, _
qdf As DAO.QueryDef, _
strSQL As String, _strHoja As String, _strArchivo As String, _strTitulo As String, _Campo As DAO.Field, _
lngColumna As Long, _i As Long, _xls As Object
Const xlWBATWorksheet = -4167
Const xlAutomatic = -4105
Const xlSolid = 1Const xlThemeColorDark1 = 1Const xlToRight = -4161
Const xlNormal = -4143
On Error GoTo ExpProgEmit_Click_TratamientoErrores
strSQL = "SELECT NombrePrograma"
strSQL = strSQL & " FROM ProgramaEmitido"
strSQL = strSQL & " GROUP BY NombrePrograma"
Set xls = CreateObject("Excel.Application")
xls.Visible = True
xls.Workbooks.Add xlWBATWorksheet
strHoja = xls.ActiveSheet.Name
Set rstNombrePrograma = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
If Not (rstNombrePrograma.EOF And rstNombrePrograma.BOF) Then
Do
strSQL = "SELECT NombrePrograma, FechaPrograma, TituloTema, NombreAutor, PaisAutor, NombreInterprete, PaisInterprete, Genero "
strSQL = strSQL & "FROM ProgramaEmitido"
strSQL = strSQL & " WHERE NombrePrograma = Parametro1"
Set qdf = CurrentDb.CreateQueryDef("", strSQL)
qdf.Parameters("Parametro1") = rstNombrePrograma!NombrePrograma
Set rstFechaPrograma = qdf.OpenRecordset
xls.activeworkbook.Sheets.Add Before:=xls.Worksheets(xls.Worksheets.Count)
xls.ActiveSheet.Name = rstNombrePrograma!NombrePrograma
With xls
lngColumna = 1For Each Campo In rstFechaPrograma.FieldsstrTitulo = ""
For i = 1 To Len(Campo.Name)
strTitulo = strTitulo & Mid(Campo.Name, i, 1)
If i < Len(Campo.Name) Then
If EsMayuscula(Mid(Campo.Name, i + 1, 1)) Then strTitulo = strTitulo & " "
End If
Next i
.ActiveSheet.Cells(1, lngColumna) = strTitulo
lngColumna = lngColumna + 1
Next Campo
.Range("A1").Select
.Range(.Selection, .Selection.End(xlToRight)).Select
.Selection.Font.Bold = True
With .Selection.Interior
.Pattern = xlSolid
.ColorIndex = 15
End With
End With
If Not (rstFechaPrograma.EOF And rstFechaPrograma.BOF) Then
xls.ActiveSheet.Cells(2, 1).CopyFromRecordset rstFechaPrograma
End If
xls.Columns("A:H").EntireColumn.AutoFit
rstNombrePrograma.MoveNextLoop Until rstNombrePrograma.EOFEnd If
xls.Application.DisplayAlerts = False
xls.activeworkbook.Worksheets(strHoja).Delete
strArchivo = "D:\SGRADIO-CAPTACIONESv1.0\SGRADIOv1.0 EXPORTACIONES\" & DLookup("FProg", "ProgramaEmitidoFecha") & " ProdMusicalv1.0.xls"
If Not Nz(strArchivo, "") = "" Then
xls.activeworkbook.SaveAs FileName:=strArchivo, FileFormat:=xlNormal
Else
xls.activeworkbook.Saved = True
End If
xls.Application.DisplayAlerts = True
ExpProgEmit_Click_Salir:On Error Resume Next
xls.QuitSet xls = NothingSet qdf = NothingCierraRecordsetDAO rstNombrePrograma
CierraRecordsetDAO rstFechaPrograma
On Error GoTo 0
Exit Sub
ExpProgEmit_Click_TratamientoErrores:MsgBox "Error " & Err & " en proc.: ExpProgEmit_Click de Documento VBA: Form_frmFrmIniCaptacion (" & Err.Description & ")", vbCritical + vbOKOnly, "ATENCION"
Resume ExpProgEmit_Click_Salir
Resume Next
End Sub
Valora esta pregunta
0