Exportar datos a excel
Hola estoy exportando datos a excel pero, necesito enviar mas de 200.000 registro y el libro aguanta como 190.000 no mas,agrego una hoja mas al libro pero muestra los datos que le envio
este codigo que les mando funciona pero cuando son mas de 200.000 se cae
Private Sub Co_Expor_Click()
Dim aux As String
Dim VarHoja As Integer
Dim aux_num As Long
Dim Libro As Workbook
Dim Hoja As Worksheet
VarHoja = 1
CD_Exp.DialogTitle = "Exportar Registros"
CD_Exp.FileName = "*.xls"
CD_Exp.Filter = ("*.xls")
CD_Exp.DefaultExt = "xls"
CD_Exp.ShowOpen
BD_1 = CD_Exp.FileName
MousePointer = 11
If BD_1 <> "*.xls" And BD_1 <> "" Then
Set Programa = CreateObject("Excel.Application")
Programa.Visible = True
Set Libro = Programa.Workbooks.Add
columnas = DataGrid1.Columns.Count
Ado_Filtro.Recordset.MoveFirst
While (Not Ado_Filtro.Recordset.EOF)
Set Hoja = Libro.Sheets(VarHoja)
For k = 0 To columnas - 1
aux = DataGrid1.Columns(k).Caption
Hoja.Cells(1, k + 1).Value = aux
Next
i = 2
While (Not Ado_Filtro.Recordset.EOF) And (i < 65000)
For j = 1 To columnas
inde = j - 1
Aux1 = Ado_Filtro.Recordset.Fields(inde)
If Not (IsNull(Aux1)) Then
aux = Trim(Aux1)
Else
aux = ""
End If
Hoja.Cells(i, j).Value = aux
Next
Ado_Filtro.Recordset.MoveNext
i = i + 1
Wend
VarHoja = VarHoja + 1
Wend
On Error GoTo error1
Hoja.SaveAs FileName:=BD_1
While paso = 1
CD_Exp.DialogTitle = "Guardar Rut en Cero"
CD_Exp.FileName = "*.xls"
CD_Exp.Filter = ("*.xls")
CD_Exp.DefaultExt = "xls"
CD_Exp.ShowOpen
BD_1 = CD_Exp.FileName
If BD_1 <> "*.xls" And BD_1 <> "" Then
paso = 0
On Error GoTo error1
Hoja.SaveAs FileName:=BD_1
End If
Wend
Appxls.Application.Quit
' Libera la variable de objeto
Set Appxls = Nothing
MsgBox ("La Exportación a Terminado")
End If
MousePointer = 1
Exit Sub
error1: paso = 1
Resume Next
End Sub
este codigo que les mando funciona pero cuando son mas de 200.000 se cae
Private Sub Co_Expor_Click()
Dim aux As String
Dim VarHoja As Integer
Dim aux_num As Long
Dim Libro As Workbook
Dim Hoja As Worksheet
VarHoja = 1
CD_Exp.DialogTitle = "Exportar Registros"
CD_Exp.FileName = "*.xls"
CD_Exp.Filter = ("*.xls")
CD_Exp.DefaultExt = "xls"
CD_Exp.ShowOpen
BD_1 = CD_Exp.FileName
MousePointer = 11
If BD_1 <> "*.xls" And BD_1 <> "" Then
Set Programa = CreateObject("Excel.Application")
Programa.Visible = True
Set Libro = Programa.Workbooks.Add
columnas = DataGrid1.Columns.Count
Ado_Filtro.Recordset.MoveFirst
While (Not Ado_Filtro.Recordset.EOF)
Set Hoja = Libro.Sheets(VarHoja)
For k = 0 To columnas - 1
aux = DataGrid1.Columns(k).Caption
Hoja.Cells(1, k + 1).Value = aux
Next
i = 2
While (Not Ado_Filtro.Recordset.EOF) And (i < 65000)
For j = 1 To columnas
inde = j - 1
Aux1 = Ado_Filtro.Recordset.Fields(inde)
If Not (IsNull(Aux1)) Then
aux = Trim(Aux1)
Else
aux = ""
End If
Hoja.Cells(i, j).Value = aux
Next
Ado_Filtro.Recordset.MoveNext
i = i + 1
Wend
VarHoja = VarHoja + 1
Wend
On Error GoTo error1
Hoja.SaveAs FileName:=BD_1
While paso = 1
CD_Exp.DialogTitle = "Guardar Rut en Cero"
CD_Exp.FileName = "*.xls"
CD_Exp.Filter = ("*.xls")
CD_Exp.DefaultExt = "xls"
CD_Exp.ShowOpen
BD_1 = CD_Exp.FileName
If BD_1 <> "*.xls" And BD_1 <> "" Then
paso = 0
On Error GoTo error1
Hoja.SaveAs FileName:=BD_1
End If
Wend
Appxls.Application.Quit
' Libera la variable de objeto
Set Appxls = Nothing
MsgBox ("La Exportación a Terminado")
End If
MousePointer = 1
Exit Sub
error1: paso = 1
Resume Next
End Sub
