Visual Basic - Ayuden u_U

Haber si pueden ayudarme...

Tengo este codigo para extraer datos de la DB hacia una hoja de calculo, pero tarda muchisimo como 5 min en formar el informe, alguien puede mejorar mi codigo para que sea mas rapido la consulta?

*****************************

Sub Conectar()
'comienza Conexion

strDB = "C:ContPAQ.mdb"
'crear la conexión

Set datConnection = New ADODB.Connection
Set recSet = New ADODB.Recordset
datConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source =" & strDB & ";"

End Sub

Sub EnglobarPeriodoyEjecicio()

Call Conectar

Sheets("Inicio").Select

' Englobamos las Variables
Range("E8").Select
Ejercicio = ActiveCell.Value
Range("E11").Select
Periodo = ActiveCell.Value

End Sub


Sub GenerarCostosGrupal()

Call Conectar

Sheets("Inicio").Select

Range("E25").Select
Ejercicio = ActiveCell.Value
Range("E27").Select
Periodo = ActiveCell.Value

Sheets("Costos Grupales").Select

Range("A7:L200").Select
Selection.EntireRow.Delete

Range("F2").Select

ActiveCell.Value = Periodo

Range("A7").Select

ActiveCell.Value = "5101000000"
PrimeraFila = ActiveCell.Row
Selection.Font.Bold = True
ActiveCell.Offset(1, 0).Select

Set recSet = datConnection.Execute("SELECT Distinct CUENTA FROM CTW10004 WHERE CUENTA LIKE '5101%' AND PERIODO=" & Periodo & " AND EJE=" & Ejercicio & " ORDER BY CUENTA ")

Do Until recSet.EOF
ActiveCell.Value = Val(recSet("CUENTA"))
ActiveCell.Offset(1, 0).Select
recSet.MoveNext
Loop

Range("A7").End(xlDown).Select
UltimaFila = ActiveCell.Row
UltimaFilaPE = ActiveCell.Row
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "5103000000"
Selection.Font.Bold = True

' Ventas mostrador Direccion
VtMostAdr = ActiveCell.Address
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "5103001000"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "5105000000"
Selection.Font.Bold = True
'Concesion Cozumel Direccion
ConczuAddr = ActiveCell.Address
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "5105001000"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "5105002000"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "5105004000"

Set recSet = Nothing
' rellenamos Nombre
Range("A7").Select

Do While ActiveCell <> Empty

NumCuenta = ActiveCell.Value
ActiveCell.Offset(0, 1).Select

Set recSet = datConnection.Execute("SELECT * FROM CTW10001 WHERE CUENTA='" & NumCuenta & "' ")

If Not recSet.BOF And Not recSet.EOF Then
ActiveCell.Value = recSet("NOMBRE")
End If
ActiveCell.Offset(1, -1).Select
Loop

Set recSet = Nothing

Range("A8").Select
Contador = 1
Do While ActiveCell <> Empty
ActiveCell.Offset(1, 0).Select
Contador = Contador + 1
Loop

Set recSet = Nothing
datConnection.Close: Set datConnection = Nothing

Call Conectar
'Rellenamos Gastos
Range("A8").Select

Empezar:

For x = 1 To Contador

NumCuenta = ActiveCell

If ActiveCell = "5105002000" Or NumCuentaING = "5105004000" Then
ActiveCell.Offset(1, 0).Select
MsgBox "Empezando"
GoTo Empezar
End If

If ActiveCell = "5105001000" Then
NumCuenta = "4105001001"
MsgBox "La cuenta es" & NumCuenta
End If

If ActiveCell.Value = Val("5103001000") Then
NumCuenta = "4103001001"
MsgBox "La cuenta es" & NumCuenta
End If

NumCuentaING = Replace(NumCuenta, "5101", "4101")

' cargos egresos
Set recSet = datConnection.Execute("SELECT Sum(IMPORTE) As Suma FROM CTW10004 WHERE CUENTA='" & NumCuenta & "' AND EJE=" & Ejercicio & " AND PERIODO=" & Periodo & " AND TIPOMOV=0")
' abonos egresos
Set recSet2 = datConnection.Execute("SELECT Sum(IMPORTE) As Suma2 FROM CTW10004 WHERE CUENTA='" & NumCuenta & "' AND EJE=" & Ejercicio & " AND PERIODO=" & Periodo & " AND TIPOMOV=-1")
' Cargos Ingresos
Set recSet3 = datConnection.Execute("SELECT Sum(IMPORTE) As Suma3 FROM CTW10004 WHERE CUENTA='" & NumCuentaING & "' AND EJE=" & Ejercicio & " AND PERIODO=" & Periodo & " AND TIPOMOV=0")
' Abonos Ingresos
Set recSet4 = datConnection.Execute("SELECT Sum(IMPORTE) As Suma4 FROM CTW10004 WHERE CUENTA='" & NumCuentaING & "' AND EJE=" & Ejercicio & " AND PERIODO=" & Periodo & " AND TIPOMOV=-1")
' cargos egresos acumulados
Set recSet5 = datConnection.Execute("SELECT Sum(IMPORTE) As Suma5 FROM CTW10004 WHERE CUENTA='" & NumCuenta & "' AND TIPOMOV=0")
' abonos egresos acumulados
Set recSet6 = datConnection.Execute("SELECT Sum(IMPORTE) As Suma6 FROM CTW10004 WHERE CUENTA='" & NumCuenta & "' AND TIPOMOV=-1")
' Cargos Ingresos Acumulados
Set recSet7 = datConnection.Execute("SELECT Sum(IMPORTE) As Suma7 FROM CTW10004 WHERE CUENTA='" & NumCuentaING & "' AND TIPOMOV=0")
' Abonos Ingresos Acumulados
Set recSet8 = datConnection.Execute("SELECT Sum(IMPORTE) As Suma8 FROM CTW10004 WHERE CUENTA='" & NumCuentaING & "' AND TIPOMOV=-1")

'Cargo ingreso
ActiveCell.Offset(0, 2).Select
ActiveCell = recSet3("Suma3")
'Abono Ingreso
ActiveCell.Offset(0, 1).Select
ActiveCell = recSet4("Suma4")
'Saldo Ingreso
ActiveCell.Offset(0, 1).Select
Fila = ActiveCell.Row
ActiveCell.Value = "=D" & Fila & "-C" & Fila & ""
'Cargo Egreso
ActiveCell.Offset(0, 1).Select
ActiveCell = recSet("Suma")
Cargo = recSet("Suma")
'Abono Egreso
ActiveCell.Offset(0, 1).Select
ActiveCell = recSet2("Suma2")
'Saldo Egreso
ActiveCell.Offset(0, 1).Select
Fila = ActiveCell.Row
ActiveCell.Value = "=F" & Fila & "-G" & Fila & ""
'Utilidad
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "=E" & Fila & "-H" & Fila & ""
' Porcentaje
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "=I" & Fila & "/E" & Fila & ""

' Cargo Ingresos Acumulados
ActiveCell.Offset(0, 1).Select
ActiveCell = recSet7("Suma7")

' Abono Ingresos Acumulados
ActiveCell.Offset(0, 1).Select
ActiveCell = recSet8("Suma8")

'Saldo Ingreso Acumulado
ActiveCell.Offset(0, 1).Select
Fila = ActiveCell.Row
ActiveCell.Value = "=L" & Fila & "-K" & Fila & ""

' Cargo Egresos Acumulados
ActiveCell.Offset(0, 1).Select
ActiveCell = recSet5("Suma5")

' Abono Egresos Acumulados
ActiveCell.Offset(0, 1).Select
ActiveCell = recSet6("Suma6")

'Saldo Egreso Acumulado
ActiveCell.Offset(0, 1).Select
Fila = ActiveCell.Row
ActiveCell.Value = "=N" & Fila & "-O" & Fila & ""

'Utilidad Acumulada
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "=M" & Fila & "-P" & Fila & ""

' Porcentaje acumulado
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "=Q" & Fila & "/M" & Fila & ""

'Regresa
ActiveCell.Offset(1, -17).Select


Next

Range("C7").Select
ActiveCell.Offset(1, 0).Select
PrimeraFila = ActiveCell.Row
ActiveCell.Offset(-1, 0).Select
ActiveCell.Value = "=Sum(C" & PrimeraFila & ":C" & UltimaFila & ")"

Range("C" & UltimaFila & "").Select
ActiveCell.Offset(2, 0).Select
FilaVmostrador = ActiveCell.Row
ActiveCell.Offset(-1, 0).Select
ActiveCell.Value = "=C" & FilaVmostrador & ""
ActiveCell.Offset(3, 0).Select
CozumelPFila = ActiveCell.Row
ActiveCell.Offset(2, 0).Select
CozumelUltimaFila = ActiveCell.Row
ActiveCell.Offset(-3, 0).Select
ActiveCell.Value = "=Sum(C" & CozumelPFila & ":C" & CozumelUltimaFila & ")"

Range("C" & PrimeraFila & "").Select
ActiveCell.Offset(-1, 0).Select
PrimeraFila = ActiveCell.Row
Selection.Copy
Range("C" & PrimeraFila & ":R" & PrimeraFila & "").Select
ActiveSheet.Paste
Selection.Font.Bold = True

Range("C" & UltimaFila & "").Select
ActiveCell.Offset(1, 0).Select
UltimaFila = ActiveCell.Row
Selection.Copy
Range("C" & UltimaFila & ":R" & UltimaFila & "").Select
ActiveSheet.Paste
Selection.Font.Bold = True

Range("C" & UltimaFila & "").Select
ActiveCell.Offset(2, 0).Select
UltimaFila = ActiveCell.Row
Selection.Copy
Range("C" & UltimaFila & ":R" & UltimaFila & "").Select
ActiveSheet.Paste
Selection.Font.Bold = True

Range("C7:R300").Select
Selection.NumberFormat = "#,##0.00;[Red]-#,##0.00"

Range("J7:J300").Select
Selection.NumberFormat = "0%"

Range("R7:R300").Select
Selection.NumberFormat = "0%"

Range("B7").Select
Selection.Font.Bold = True
Range("A8:A" & UltimaFilaPE & "").Select

Selection.Rows.Group

Range("A" & UltimaFilaPE & "").Select
ActiveCell.Offset(1, 1).Select
Selection.Font.Bold = True
ActiveCell.Offset(1, -1).Select
Selection.Rows.Group
ActiveCell.Offset(1, 1).Select
Selection.Font.Bold = True
ActiveCell.Offset(1, -1).Select
Inicio = ActiveCell.Row
ActiveCell.Offset(2, 0).Select
Final = ActiveCell.Row

Range("A" & Inicio & ":B" & Final & "").Select
Selection.Rows.Group

Range("A7").End(xlDown).Select
Finaldetodo = ActiveCell.Row

Range("A7:A" & Finaldetodo & "").Select
Selection.NumberFormat = "0000-000-000"

Set recSet = Nothing
datConnection.Close: Set datConnection = Nothing

End Sub

¿En verdad crees que alguien se va a leer todo el ladrillote que pusiste?