Forums Últimos mensajes - Powered by IBM
 

ALGUIEN SABE HACER ESTO MEJOR Y MÁS RESUMIDO. MI OBJETIVO ES APRENDER

18/05/2009 - 12:22 por Anonimo | Informe spam
Un saludo. Utilizo excel 2007. Este código hace exactamente lo que yo
quiero, pero seguro que se puede mejorar y me gustaría ver si alguien
pudiera enseñarme. Lo hago paso a paso para no equivocarme.

Gracias

Dim hoja As Worksheet



Public Sub Macro1()
'
' Macro1 Macro
'

'


datos = Array(119, 122, 125, 126, 127, 128, 129, 130, 131, 133, 134, 135,
136, 137, _
138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149)

x = 1
For Each jose In datos
With Sheets("hoja1").QueryTables.Add(Connection:= _
"URL;http://www.futbolcracks.com/consult...amp="
& jose & "", _
Destination:=Sheets("hoja1").Range("$A$" & (x * 50) - 49 & ""))
.Name = "equipo" & jose
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "3"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With

x = x + 1
Next


End Sub

Sub borrar_tablas()

For Each datos In Sheets("hoja1").QueryTables

datos.Delete

Next

End Sub

Sub borrar_filas_sobran()

Sheets("hoja1").Range("d:k").EntireColumn.Delete

End Sub

Sub ajustar_fila_A()

Sheets("hoja1").Range("a:a").ColumnWidth = 5

End Sub

Sub poner_categoria_equipo()

ultfila = Sheets("hoja1").Range("b5000").End(xlUp).Row


datos = Array(119, 122, 125, 126, 127, 128, 129, 130, 131, 133, 134, 135,
136, 137, _
138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149)

x = 0
For fila = 3 To ultfila Step 50

Sheets("hoja1").Range("e" & fila) = datos(x)
Sheets("hoja1").Range("d" & fila & ":d" & Range("c" &
fila).End(xlDown).Row).Formula = "=+VLOOKUP($E$" & fila & ",equipos,2)"
Sheets("hoja1").Range("d" & fila & ":d" & Range("c" &
fila).End(xlDown).Row).Copy
Sheets("hoja1").Range("d" & fila).PasteSpecial xlPasteValues

Application.CutCopyMode = False



x = x + 1
Next

End Sub


Sub borrar_fila_sobrante()

Sheets("hoja1").Range("e:e").EntireColumn.Delete

End Sub

Sub copiar_datos_hoja_resumen()

Set hoja = Sheets("resumen")

ultfila = Range("b5000").End(xlUp).Row

For fila = 1 To ultfila Step 50

Sheets("hoja1").Range("a" & fila).CurrentRegion.Copy
hoja.Range("a" & hoja.Range("a10000").End(xlUp).Row + 1).PasteSpecial
xlPasteValues

Next

Set hoja = Nothing

End Sub

Sub borrar_filas_vacias()

Set hoja = Sheets("resumen")

ultfila = hoja.Range("b5000").End(xlUp).Row

For fila = ultfila To 1 Step -1

If IsEmpty(hoja.Range("b" & fila)) = True Then hoja.Range("b" &
fila).EntireRow.Delete
If hoja.Range("b" & fila) = "Equipo" Then hoja.Range("b" &
fila).EntireRow.Delete

Next

Set hoja = Nothing


End Sub


Sub insertar_fila()


Set hoja = Sheets("resumen")

hoja.Rows("1:1").Insert

Set hoja = Nothing

End Sub

Sub insertar_encabezado()

Set hoja = Sheets("resumen")

hoja.Range("a1:d1") = Array("ORDEN", "EQUIPO", "PUNTOS", "CATEGORIA")

hoja.Range("a1").CurrentRegion.Columns.AutoFit

Set hoja = Nothing

End Sub
Sub Hacer_tabla()

Sheets("resumen").Select

Set hoja = Sheets("resumen")

hoja.ListObjects.Add(xlSrcRange, hoja.Range("a1").CurrentRegion, ,
xlYes).Name = _
"Tabla1"
Range("Tabla1[#All]").Select
hoja.ListObjects("Tabla1").TableStyle = "TableStyleLight14"
Range("Tabla1[[#Headers],[ORDEN]]").Select


Set hoja = Nothing


End Sub

Sub Quitar_de_Lista()

Set hoja = Sheets("resumen")

Dim n As Byte
With hoja
For n = 1 To .ListObjects.Count
.ListObjects(1).Unlist
Next
End With

Set hoja = Nothing

End Sub

Sub numerar_equipos()

Set hoja = Sheets("resumen")

hoja.Range("a2") = 1

ultfila = hoja.Range("b5000").End(xlUp).Row

hoja.Range("a3:a" & ultfila).Formula = "=+(1+a2)"

hoja.Range("a2:a" & ultfila).Copy
hoja.Range("a2").PasteSpecial xlPasteValues

hoja.Range("a1").Activate



Set hoja = Nothing

End Sub


Sub procedimiento()

Application.CutCopyMode = False
Application.ScreenUpdating = False

Sheets("hoja1").Range("a1:g10000").Clear
Sheets("resumen").Range("a1").CurrentRegion.Clear




Call Macro1
Call borrar_tablas
Call borrar_filas_sobran
Call ajustar_fila_A
Call poner_categoria_equipo
Call borrar_fila_sobrante
Call copiar_datos_hoja_resumen
Call borrar_filas_vacias
Call insertar_fila
Call insertar_encabezado
Call Hacer_tabla
Call Quitar_de_Lista
Call numerar_equipos

Application.CutCopyMode = False

Application.ScreenUpdating = True

End Sub
 

Leer las respuestas

#1 Gabriela
18/05/2009 - 20:07 | Informe spam
On May 18, 5:22 am, wrote:
Un saludo. Utilizo excel 2007. Este código hace exactamente lo que yo
quiero, pero seguro que se puede mejorar y me gustaría ver si alguien
pudiera enseñarme. Lo hago paso a paso para no equivocarme.

Gracias





Hola

Algunos buenas practicas para empezar...

- Siempre utiliza la instrucción "Option Explicit" como primera
instrucción en cualquier módulo / hoja con algún procedimiento. Esta
instrucción te obliga a declarar todas las variables que se utilizan
lo cual trae algunas ventajas.

- Siempre agrega comentarios, lo que es claro para ti, no lo es para
las demas personas que vean tu código, y tal vez no será claro para ti
despues de algunos meses.

- No es buena idea nombrar a una variable "jose". Es mejor utilizar
nombres que tengan algun significado y que facilite la lectura de
código.

- Utiliza prefijos en los nombres de las variables, por ejemplo: "Dim
varDatos as Variant" o "Dim intCount as Integer".

- Declara a tus variables en el procedimiento principal, y pasa los
valores como parametros a los otros procedimientos, por ejemplo:

Sub procedimiento()
Dim varDatos As Variant
varDatos = Array(119, 122, 125, 126, 127, 128, 129, 130, 131, 133,
134, 135, 136, 137, _
138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149)
Call Macro1(varDatos)
.
.
.
End Sub

Sub Macro1(varDatos As Variant)
.
.
End Sub

- No veo ninguna razón práctica para hacer procedimientos con una sola
instrucción, en lugar del "Call" utiliza la instrucción en tu
procedimiento principal
-Haz que tus procedimientos sean "reutilizables", por ejemplo, en
lugar de

Sub borrar_filas_vacias()
Set hoja = Sheets("resumen")
.
.
Set hoja = Nothing
End Sub

Sería de esta manera, eliminando las instrucciones "Set"
Sub borrar_filas_vacias(hoja As Worksheet)
.
.
End Sub

Espero que esto sea de utilidad

Gabriela Cerra

Preguntas similares