Header Ads

EJEMPLO GRAF

0:37:00 0
Dim NumeroDeNiveles As Integer
Dim NoColumnaIT As Integer
Dim NoFilaIT As Integer
Dim Punto As String
Dim TituloDriftX As String
Dim TituloDriftY As String
Dim AuxNumeroNiveles As Integer
Dim AuxNumeroV As Long
Dim NoPuntos As Integer
Dim RangoTitulos As Range
Dim NoColTU As Integer
Dim NoFilTU As Long
Dim AuxTBU As String
Dim RangoFor As Range
Dim MaxFOR As Single
Dim MinFOR As Single
Dim AuxNoNiveles As Long




Punto = "PUNTO"
TituloDriftX = "DRIFT X"
TituloDriftY = "DRIFT Y"

NoPuntos = Application.InputBox(prompt:=" Ingresa el numero de Puntos a Realizar", Title:="NÚMERO DE PUNTOS", Type:=1)
NumeroDeNiveles = Application.InputBox(prompt:="Ingresa el Numero de Niveles con el que cuenta la Estructura: ", Title:="NÚMERO DE NIVELES DE LA ESTRCUTURA", Type:=1)
NoColumnaIT = Application.InputBox(prompt:="Ingresa el Número de la Columna donde quieres insertar la TABLA RESUMEN", Title:="NÚMERO DE COLUMNA PARA INSERTAR TABLA RESUMEN", Type:=1)
NoFilaIT = Application.InputBox(prompt:="Ingresa el Número de la Fila donde quieres Insertar la TABLA RESUMEN", Title:="NÚMERO DE FILA PARA INSERTAR TABLA RESUMEN", Type:=1)
NoColTU = Application.InputBox("Ingresa la Columna de inicio de la Tabla que realizaste", "NÚMERO COLUMNA DATOS USUARIO", Type:=1)

NoFilTU = Application.InputBox("Ingresa la Fila de inicio de la Tabla que realizaste", "NÚMERO FILA DATOS USUARIO", Type:=1)
Set RangoTitulos = Application.InputBox("Ingresa el rango de los encabezados de Drifts", "RANGO TITULOS DRIFTS", Type:=8)

AuxNumeroNiveles = NumeroDeNiveles - 1
AuxNumeroV = NumeroDeNiveles + 1

    For NoPuntos = 1 To NoPuntos
        
        If NoPuntos = 1 Then
            Cells(NoFilaIT, NoColumnaIT) = TituloDriftX
            Cells(NoFilaIT + 1, NoColumnaIT) = Punto
            Cells(NoFilaIT + 2, NoColumnaIT) = "NIVEL"
            Cells(NoFilaIT + 2, NoColumnaIT + 1) = "MÁX"
            Cells(NoFilaIT + 2, NoColumnaIT + 2) = "MÍN"
            
            Cells(NoFilaIT, NoColumnaIT + 4) = TituloDriftY
            Cells(NoFilaIT + 1, NoColumnaIT + 4) = Punto
            Cells(NoFilaIT + 2, NoColumnaIT + 4) = "NIVEL"
            Cells(NoFilaIT + 2, NoColumnaIT + 5) = "MÁX"
            Cells(NoFilaIT + 2, NoColumnaIT + 6) = "MÍN"
            
            For AuxNumeroV = 1 To AuxNumeroV
                If AuxNumeroV = 1 Then
                
                    Cells(NoFilaIT + 3, NoColumnaIT).Select
                    ActiveCell = NumeroDeNiveles
                    AuxNoNiveles = (NumeroDeNiveles * 2) - 1
                    
                    Cells(NoFilaIT + 3, NoColumnaIT + 1).Select
                    AuxTBU = Cells(NoFilTU, NoColTU + AuxNoNiveles).Value
                    RangoTitulos.Find(what:=AuxTBU).Select
                    ActiveCell.Offset(1, 0).Select
                    Set RangoFor = Range(Selection, Selection.End(xlDown))
                    MaxFOR = Application.WorksheetFunction.Max(RangoFor)
                    
                    Cells(NoFilaIT + 3, NoColumnaIT).Select
                    ActiveCell.Offset(0, 1).Select
                    ActiveCell.Value = MaxFOR
                    
                    Cells(NoFilaIT + 3, NoColumnaIT + 2).Select
                    AuxTBU = Cells(NoFilTU, NoColTU + AuxNoNiveles).Value
                    RangoTitulos.Find(what:=AuxTBU).Select
                    ActiveCell.Offset(1, 0).Select
                    Set RangoFor = Range(Selection, Selection.End(xlDown))
                    MinFOR = Application.WorksheetFunction.Min(RangoFor)
                    
                    Cells(NoFilaIT + 3, NoColumnaIT + 1).Select
                    ActiveCell.Offset(0, 1).Select
                    ActiveCell.Value = MinFOR
                    
                    
                    Cells(NoFilaIT + 3, NoColumnaIT + 4) = NumeroDeNiveles
                    AuxNoNiveles = AuxNoNiveles + 1
                    Cells(NoFilaIT + 3, NoColumnaIT + 5).Select
                    AuxTBU = Cells(NoFilTU, NoColTU + AuxNoNiveles).Value
                    RangoTitulos.Find(what:=AuxTBU).Select
                    ActiveCell.Offset(1, 0).Select
                    Set RangoFor = Range(Selection, Selection.End(xlDown))
                    MaxFOR = Application.WorksheetFunction.Max(RangoFor)
                    
                    Cells(NoFilaIT + 3, NoColumnaIT + 4).Select
                    ActiveCell.Offset(0, 1).Select
                    ActiveCell.Value = MaxFOR
                    
                    Cells(NoFilaIT + 3, NoColumnaIT + 6).Select
                    AuxTBU = Cells(NoFilTU, NoColTU + AuxNoNiveles).Value
                    RangoTitulos.Find(what:=AuxTBU).Select
                    ActiveCell.Offset(1, 0).Select
                    Set RangoFor = Range(Selection, Selection.End(xlDown))
                    MinFOR = Application.WorksheetFunction.Min(RangoFor)
                    
                    Cells(NoFilaIT + 3, NoColumnaIT + 5).Select
                    ActiveCell.Offset(0, 1).Select
                    ActiveCell.Value = MinFOR
                    
                    NoFilaIT = NoFilaIT + 3
                    
                Else
                
                    NoFilaIT = NoFilaIT + 1
                    Cells(NoFilaIT, NoColumnaIT) = AuxNumeroNiveles
                    Cells(NoFilaIT, NoColumnaIT + 1).Select
                    NumeroDeNiveles = NumeroDeNiveles - 1
                    AuxNoNiveles = (NumeroDeNiveles * 2) - 1
                    AuxTBU = Cells(NoFilTU, NoColTU + AuxNoNiveles).Value
                    
                    RangoTitulos.Find(what:=AuxTBU).Select
                    ActiveCell.Offset(1, 0).Select
                    Set RangoFor = Range(Selection, Selection.End(xlDown))
                    MaxFOR = Application.WorksheetFunction.Max(RangoFor)
                    
                    Cells(NoFilaIT, NoColumnaIT).Select
                    ActiveCell.Offset(0, 1).Select
                    ActiveCell.Value = MaxFOR
                    
                    Cells(NoFilaIT, NoColumnaIT + 2).Select
                    AuxTBU = Cells(NoFilTU, NoColTU + AuxNoNiveles).Value
                    RangoTitulos.Find(what:=AuxTBU).Select
                    ActiveCell.Offset(1, 0).Select
                    Set RangoFor = Range(Selection, Selection.End(xlDown))
                    MinFOR = Application.WorksheetFunction.Min(RangoFor)
                    
                    Cells(NoFilaIT, NoColumnaIT + 1).Select
                    ActiveCell.Offset(0, 1).Select
                    ActiveCell.Value = MinFOR
                    
                  
               
                    Cells(NoFilaIT, NoColumnaIT + 4) = AuxNumeroNiveles
                    Cells(NoFilaIT, NoColumnaIT + 5).Select
                    AuxNoNiveles = (NumeroDeNiveles * 2)
                    AuxTBU = Cells(NoFilTU, NoColTU + AuxNoNiveles).Value
                    
                    RangoTitulos.Find(what:=AuxTBU).Select
                    ActiveCell.Offset(1, 0).Select
                    Set RangoFor = Range(Selection, Selection.End(xlDown))
                    MaxFOR = Application.WorksheetFunction.Max(RangoFor)
                    
                    Cells(NoFilaIT, NoColumnaIT + 4).Select
                    ActiveCell.Offset(0, 1).Select
                    ActiveCell.Value = MaxFOR
                    
                    
                    Cells(NoFilaIT, NoColumnaIT + 6).Select
                    
                    AuxTBU = Cells(NoFilTU, NoColTU + AuxNoNiveles).Value
                    RangoTitulos.Find(what:=AuxTBU).Select
                    ActiveCell.Offset(1, 0).Select
                    Set RangoFor = Range(Selection, Selection.End(xlDown))
                    MinFOR = Application.WorksheetFunction.Min(RangoFor)
                    
                    Cells(NoFilaIT, NoColumnaIT + 5).Select
                    ActiveCell.Offset(0, 1).Select
                    ActiveCell.Value = MinFOR
                    
                    
                    
                    
                    
                    
                    
                    
                    
                    AuxNumeroNiveles = AuxNumeroNiveles - 1
                End If
            Next AuxNumeroV
            
            NoFilaIT = NoFilaIT + 12
            Else
            
            Cells(NoFilaIT, NoColumnaIT) = TituloDriftX
            Cells(NoFilaIT + 1, NoColumnaIT) = Punto
            Cells(NoFilaIT + 2, NoColumnaIT) = "NIVEL"
            Cells(NoFilaIT + 2, NoColumnaIT + 1) = "MÁX"
            Cells(NoFilaIT + 2, NoColumnaIT + 2) = "MÍN"
            
            Cells(NoFilaIT, NoColumnaIT + 4) = TituloDriftY
            Cells(NoFilaIT + 1, NoColumnaIT + 4) = Punto
            Cells(NoFilaIT + 2, NoColumnaIT + 4) = "NIVEL"
            Cells(NoFilaIT + 2, NoColumnaIT + 5) = "MÁX"
            Cells(NoFilaIT + 2, NoColumnaIT + 6) = "MÍN"
            AuxNumeroV = AuxNumeroV - 1
            
            For AuxNumeroV = 1 To AuxNumeroV
                If AuxNumeroV = 1 Then
                    Cells(NoFilaIT + 3, NoColumnaIT) = NumeroDeNiveles
                    Cells(NoFilaIT + 3, NoColumnaIT + 4) = NumeroDeNiveles
                    NoFilaIT = NoFilaIT + 3
                    AuxNumeroNiveles = NumeroDeNiveles - 1
                Else
                    NoFilaIT = NoFilaIT + 1
                    Cells(NoFilaIT, NoColumnaIT) = AuxNumeroNiveles
                    Cells(NoFilaIT, NoColumnaIT + 4) = AuxNumeroNiveles
                    AuxNumeroNiveles = AuxNumeroNiveles - 1
                End If
            Next AuxNumeroV
            
            NoFilaIT = NoFilaIT + 8
            
            
         End If
    Next NoPuntos

https://drive.google.com/open?id=1GWIsKC2Tp3oIG77IL6U2qyVJQqaRfTcR


https://drive.google.com/open?id=10DZpUSzDoakmh_s8KwGBTqApkyMu7AiG
ETIQUETAS:

No hay comentarios

Suscribirse a: Enviar comentarios ( Atom )
Con la tecnología de Blogger.