Forums Últimos mensajes - Powered by IBM
 
Tags Palabras claves

Todo un reto!

01/02/2006 - 17:30 por Txer | Informe spam
Ayuda Hacer una pregunta
Os expongo mi reto, yo usé la grabadora de macros para intentar
evolucionar a partir de ahí pero el código se refiere a las celdas
usadas en ese momento y que yo seleccioné usando "mi cabeza" lo que
quiero es que Excel lo haga por mi.

Parto de dos columnas de datos con cerca de 4000 valores cada una
(puede variar) en una hoja de Excel (hoja 1).La columna primera es
Potencia (de 0 a 7500 aprox.) la segunda Vibración (de 200 a 400
aprox.), las dos columnas están relacionadas, a cada potencia hay un
nivel de vibración.

En primer lugar lo que hago es borrar los valores de potencia y
vibración en los cuales el valor de potencia es cero, para ello ordeno
las dos columnas en función de la columna de potencia, selecciono
todas las que son cero y las borro (tanto la celda de potencia como la
de vibración).

Para el segundo paso en primer lugar y en otra hoja (hoja 2) creo unos
encabezados de fila con los rangos de potencia que me interesan (0-499,
500-999, 1000-1499...hasta 6500-7500) y a la derecha de cada rango
quiero poner la media de los valores de vibración correspondientes a
todos los valores de potencia contenidos en ese rango de la hoja 1.
Para ello uso la función PROMEDIO y selecciono a mano todos los
valores de vibración correspondientes a los valores de potencia
comprendidos entre 0-499, 500-999, 1000-1499, etc...
Con esto lo habría hecho para un día pongamos el 1 de Agosto de 2005.
A continuación lo debería de hacer para el 5 de Septiembre, el 8 de
Octubre, o la fecha que sea.

Para ello pongo otras dos columnas de datos (las obtengo de archivos de
texto con los valores separados por tabulación) a continuación de las
primeras y hago todo el proceso de la hoja 1 y luego el de la hoja 2.
Los valores medios de vibración los pongo en la siguiente columna de
la hoja 2, poniendole a cada columna la fecha como encabezado.
Y así hasta que haya procesado todos los datos.

Yo he conseguido ordenar la columna y borrar los valores iguales a cero
pero el tema de seleccionar según los rangos de potencia, etc..se me
escapa, he intentado cosas pero sin éxito, no se como hacer en código
que salte a la columna siguiente vuelva a ordenar y borrar y haga lo
mismo con las medias y demás..

Si alguno dominais y me podeis ayudar os lo agradecería en el alma.
email Siga el debateRespuesta 25 respuestasRespuesta Tengo una respuesta

Preguntas similare

Mostrar todos los temas similares

Leer las respuestas

#11 Txer
09/02/2006 - 13:57 | Informe spam
Hola KL!

Tu solución funciona de maravilla!
A riesgo de resultar pesado si que hay una cosa que se me olvido poner
ayer y que quizás sea la más importante, y es una manera para ordenar
las columnas, esto es, que las columnas aparezcan ordenadas por fecha,
de los más antiguos a los más modernos. Por otra parte el tema de
poder dividir por 100 los valores medios es muy complicado?

Muchas Gracias

Txer
Respuesta Responder a este mensaje
#12 KL
09/02/2006 - 15:05 | Informe spam
Hola Txer,

que las columnas aparezcan ordenadas por fecha,
de los más antiguos a los más modernos
poder dividir por 100 los valores medios es muy complicado?



Estoy empezando a perderme :-) Prueba el codigo que te pongo mas abajo.
Saludos,
KL

'-Inicio Codigo--
Option Explicit

Const sRuta = "C:\CANAL_2\" 'ruta hacia los ficheros de texto
Const sFiltro = "*.txt" 'filtro, otro ejemplo: "PV01A01H2_*.txt"
Const lCat = 14 'numero de rangos/categorias a crear en hoja 2

Sub principal()
Dim sBusc As String
Dim sArchivo As String
Dim sTxt As String
Dim sRng1 As String
Dim sRng2 As String
Dim lCont As Long
Dim vLista As Variant
Dim dtFecha As Date
Dim oCelda1 As Range
Dim oCelda2 As Range

'Establecemos las variables
sBusc = Dir(sRuta & sFiltro)
Set oCelda1 = ThisWorkbook.Sheets(1).Range("A1")
Set oCelda2 = ThisWorkbook.Sheets(2).Range("A1")

'Sacamos la lista de los ficheros de texto
If sBusc = "" Then GoTo Salida
ReDim vLista(0)
Do While sBusc <> ""
vLista(UBound(vLista)) = sBusc
ReDim Preserve vLista(UBound(vLista) + 1)
sBusc = Dir()
Loop
ReDim Preserve vLista(UBound(vLista) - 1)

'Congelamos la pantalla
Application.ScreenUpdating = False

'Preparamos las hojas
'Limpiamos ambas hojas
oCelda1.Parent.Cells.ClearContents
oCelda2.Parent.Cells.ClearContents
For lCont = 0 To lCat
'Creamos los titulos de filas en hoja 2
oCelda2.Offset(lCont + 1) = lCont * 50
Next lCont
'Procesamos todos los ficheros de texto extraidos
For lCont = LBound(vLista) To UBound(vLista)
'asignamos el nombre y la ruta a una variable
sArchivo = vLista(lCont)
'Extraemos la cadena de texto de la fecha
sTxt = Left(Right(sArchivo, 10), 6)
'Convertimos el texto en formato fecha
dtFecha = DateSerial(Right(sTxt, 2), _
Mid(sTxt, 3, 2), Left(sTxt, 2))
'Ponemos los encabezados en hoja 2
oCelda2.Offset(, lCont + 1) = dtFecha
'Importamos las columnas 2 y 3 de cada fichero de texto
'llamando el procedimiento "ImportarDatos" que esta
'debajo de este procedimiento y que require dos
'parametros: nombre completo del fichero (incl. ruta)
'y el objeto celda donde se van a introducir los datos.
ImportarDatos sArchivo, oCelda1.Offset(, 2 * lCont)
Next lCont
'Creamos la fromula del primer rango que excluye 0.
For lCont = 0 To UBound(vLista)
'rango a evaluar
sRng1 = _
oCelda1.Offset(, lCont * 2).EntireColumn. _
Address(, True, xlA1, True)
'rango a sumar
sRng2 = _
oCelda1.Offset(, lCont * 2 + 1).EntireColumn. _
Address(, True, xlA1, True)
oCelda2.Offset(1, lCont + 1) = _
"=(SUMIF(" & sRng1 & ","">""&$A2," & sRng2 & ")-SUMIF(" _
& sRng1 & ","">=""&$A3," & sRng2 & "))/(COUNTIF(" _
& sRng1 & ","">""&$A2)-COUNTIF(" & sRng1 & _
","">=""&$A3))"
Next lCont
'Creamos el resto de las formulas
For lCont = 0 To UBound(vLista)
'rango a evaluar
sRng1 = _
oCelda1.Offset(, lCont * 2).EntireColumn. _
Address(, True, xlA1, True)
'rango a sumar
sRng2 = _
oCelda1.Offset(, lCont * 2 + 1).EntireColumn. _
Address(, True, xlA1, True)
oCelda2.Offset(2, lCont + 1) = _
"=(SUMIF(" & sRng1 & ","">=""&$A3," & sRng2 & ")-SUMIF(" _
& sRng1 & ","">=""&$A4," & sRng2 & "))/(COUNTIF(" _
& sRng1 & ","">=""&$A3)-COUNTIF(" & sRng1 & _
","">=""&$A4))"
Next lCont
'Copiamos las formulas
With oCelda2
With .Offset(2, 1)
.Resize(, UBound(vLista) + 1) _
.AutoFill .Resize(lCat, UBound(vLista) + 1)
End With
With .Parent.UsedRange
With .Offset(, 1).Resize(, .Columns.Count - 1)
'Ordenamos columnas
.Sort _
Key1:=Range("B1"), _
Order1:=xlAscending, _
Header:=xlYes, _
Orientation:=xlLeftToRight
'Eliminamos formulas
.Value = .Value
'Dividimos por 100
oCelda2 = 100
oCelda2.Copy
.PasteSpecial xlValues, xlPasteSpecialOperationDivide
oCelda2 = ""
End With
End With
'Modificamos los titulos de filas
.Offset(1) = "'1-49"
For lCont = 1 To lCat
'Creamos los titulos de filas en hoja 2
.Offset(lCont + 1) = "'" & lCont * 50 & _
"-" & (lCont + 1) * 50 - 1
Next lCont
.Offset(lCont) = "'" & lCont * 50 & "+"
With .Parent.UsedRange
'Eliminamos errores
On Error Resume Next
.SpecialCells(xlCellTypeConstants, xlErrors) _
.ClearContents
On Error GoTo 0
'Ajustamos el ancho de columnas
.EntireColumn.AutoFit
End With
End With
Salida:
'Descongelamos la pantalla
Application.ScreenUpdating = True
End Sub

Sub ImportarDatos(sArchivo As String, oCelda As Range)
Dim qt As QueryTable
Set qt = oCelda.Parent.QueryTables.Add("TEXT;" & sArchivo, oCelda)
With qt
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileColumnDataTypes = Array(9, 1, 1)
.Refresh
.Delete
End With
End Sub
'-Fin Codigo--
Respuesta Responder a este mensaje
#13 Txer
09/02/2006 - 16:07 | Informe spam
Je,je!! Ya siento liarte tanto. Has entendido muy bien, ha ordenado las
columnas y ha divido por 100 los valores de vibración (ahora tienen su
valor real) pero también se ha dividido por 100 las fechas por, lo que
por ejemplo antes era 18/07/05 ha pasado a ser 19/01/1901 12:14:24.

Supongo que el tema es que en la operación de dividir hay que
indicarle que ignore el encabezado no?


'Dividimos por 100
oCelda2 = 100
oCelda2.Copy
.PasteSpecial xlValues, xlPasteSpecialOperationDivide
oCelda2 = ""
Respuesta Responder a este mensaje
#14 KL
09/02/2006 - 16:40 | Informe spam
Hola,

A ver este.

Saludos,
KL

'-Inicio Codigo--
Option Explicit

Const sRuta = "C:\CANAL_2\" 'ruta hacia los ficheros de texto
Const sFiltro = "*.txt" 'filtro, otro ejemplo: "PV01A01H2_*.txt"
Const lCat = 14 'numero de rangos/categorias a crear en hoja 2

Sub principal()
Dim sBusc As String
Dim sArchivo As String
Dim sTxt As String
Dim sRng1 As String
Dim sRng2 As String
Dim lCont As Long
Dim vLista As Variant
Dim dtFecha As Date
Dim oCelda1 As Range
Dim oCelda2 As Range

'Establecemos las variables
sBusc = Dir(sRuta & sFiltro)
Set oCelda1 = ThisWorkbook.Sheets(1).Range("A1")
Set oCelda2 = ThisWorkbook.Sheets(2).Range("A1")

'Sacamos la lista de los ficheros de texto
If sBusc = "" Then GoTo Salida
ReDim vLista(0)
Do While sBusc <> ""
vLista(UBound(vLista)) = sBusc
ReDim Preserve vLista(UBound(vLista) + 1)
sBusc = Dir()
Loop
ReDim Preserve vLista(UBound(vLista) - 1)

'Congelamos la pantalla
Application.ScreenUpdating = False

'Preparamos las hojas
'Limpiamos ambas hojas
oCelda1.Parent.Cells.ClearContents
oCelda2.Parent.Cells.ClearContents
For lCont = 0 To lCat
'Creamos los titulos de filas en hoja 2
oCelda2.Offset(lCont + 1) = lCont * 50
Next lCont

'Procesamos todos los ficheros de texto extraidos
For lCont = LBound(vLista) To UBound(vLista)
'asignamos el nombre y la ruta a una variable
sArchivo = vLista(lCont)
'Extraemos la cadena de texto de la fecha
sTxt = Left(Right(sArchivo, 10), 6)
'Convertimos el texto en formato fecha
dtFecha = DateSerial(Right(sTxt, 2), _
Mid(sTxt, 3, 2), Left(sTxt, 2))
'Ponemos los encabezados en hoja 2
oCelda2.Offset(, lCont + 1) = dtFecha
'Importamos las columnas 2 y 3 de cada fichero de texto
'llamando el procedimiento "ImportarDatos" que esta
'debajo de este procedimiento y que require dos
'parametros: nombre completo del fichero (incl. ruta)
'y el objeto celda donde se van a introducir los datos.
ImportarDatos sArchivo, oCelda1.Offset(, 2 * lCont)
Next lCont

'Creamos la fromula del primer rango que excluye 0.
For lCont = 0 To UBound(vLista)
'rango a evaluar
sRng1 = _
oCelda1.Offset(, lCont * 2).EntireColumn. _
Address(, True, xlA1, True)
'rango a sumar
sRng2 = _
oCelda1.Offset(, lCont * 2 + 1).EntireColumn. _
Address(, True, xlA1, True)
oCelda2.Offset(1, lCont + 1) = _
"=(SUMIF(" & sRng1 & ","">""&$A2," & sRng2 & ")-SUMIF(" _
& sRng1 & ","">=""&$A3," & sRng2 & "))/(COUNTIF(" _
& sRng1 & ","">""&$A2)-COUNTIF(" & sRng1 & _
","">=""&$A3))"
Next lCont

'Creamos el resto de las formulas
For lCont = 0 To UBound(vLista)
'rango a evaluar
sRng1 = _
oCelda1.Offset(, lCont * 2).EntireColumn. _
Address(, True, xlA1, True)
'rango a sumar
sRng2 = _
oCelda1.Offset(, lCont * 2 + 1).EntireColumn. _
Address(, True, xlA1, True)
oCelda2.Offset(2, lCont + 1) = _
"=(SUMIF(" & sRng1 & ","">=""&$A3," & sRng2 & ")-SUMIF(" _
& sRng1 & ","">=""&$A4," & sRng2 & "))/(COUNTIF(" _
& sRng1 & ","">=""&$A3)-COUNTIF(" & sRng1 & _
","">=""&$A4))"
Next lCont

'Copiamos las formulas
With oCelda2
With .Offset(2, 1)
.Resize(, UBound(vLista) + 1) _
.AutoFill .Resize(lCat, UBound(vLista) + 1)
End With
With .Parent.UsedRange
With .Offset(, 1).Resize(, .Columns.Count - 1)
'Ordenamos columnas
.Sort _
Key1:=Range("B1"), _
Order1:=xlAscending, _
Header:=xlYes, _
Orientation:=xlLeftToRight
'Eliminamos formulas
.Value = .Value
'Dividimos por 100
oCelda2 = 100
oCelda2.Copy
.Offset(1).Resize(.Rows.Count - 1) _
.PasteSpecial xlValues, xlPasteSpecialOperationDivide
oCelda2 = ""
End With
End With
'Modificamos los titulos de filas
.Offset(1) = "'1-49"
For lCont = 1 To lCat
'Creamos los titulos de filas en hoja 2
.Offset(lCont + 1) = "'" & lCont * 50 & _
"-" & (lCont + 1) * 50 - 1
Next lCont
.Offset(lCont) = "'" & lCont * 50 & "+"
With .Parent.UsedRange
'Eliminamos errores
On Error Resume Next
.SpecialCells(xlCellTypeConstants, xlErrors) _
.ClearContents
On Error GoTo 0
'Ajustamos el ancho de columnas
.EntireColumn.AutoFit
End With
End With
Salida:
'Descongelamos la pantalla
Application.ScreenUpdating = True
End Sub

Sub ImportarDatos(sArchivo As String, oCelda As Range)
Dim qt As QueryTable
Set qt = oCelda.Parent.QueryTables.Add("TEXT;" & sArchivo, oCelda)
With qt
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileColumnDataTypes = Array(9, 1, 1)
.Refresh
.Delete
End With
End Sub
'-Fin Codigo--
Respuesta Responder a este mensaje
#15 Txer
09/02/2006 - 18:50 | Informe spam
Hola!

Me he dado cuenta de que en los dos últimos códigos que has escrito
al ejecutarlo sobre un libro nuevo da un error en:

Error 1004.
La referencia de ordenación no es válida. Compruebe que está dentro
de los datos que desea ordenar y que el primer cuadro de Ordenar por no
es el mismo o está en blanco.

.Sort _
Key1:=Range("B1"), _
Order1:=xlAscending, _
Header:=xlYes, _
Orientation:=xlLeftToRight

Si le doy a continuar parece que acaba bien.

Gracias
Respuesta Responder a este mensaje
Ads by Google
Help Hacer una preguntaSiguiente AnteriorRespuesta Tengo una respuesta
Search Busqueda sugerida