Macro

[fredycayo]

Buenas noches.

Estimados es para pedirle su apoyo en optimizar mi trabajo, explicó en el adjunto y también quiero agradecer el apoyo de cada uno de ustedes, del esfuerzo y la dedicación que le ponen al contribuir sus conocimientos incondicionalmente.

Saludos.

P543a.xlsm

[dogwall]

De dónde sale el cálculo de la columna H?

[fredycayo]

En 2/8/2021 at 21:50 , fredycayo dijo:

Buenas noches.

Estimados es para pedirle su apoyo en optimizar mi trabajo, explicó en el adjunto y también quiero agradecer el apoyo de cada uno de ustedes, del esfuerzo y la dedicación que le ponen al contribuir sus conocimientos incondicionalmente.

Saludos.

 

P543a.xlsm 33.77 kB · 2 descargas

Buen día,

Agradezco por el tiempo, es valor de la columna A

BF1...

PC1...

PRD...

PDR..

[dogwall]

En 5/8/2021 at 19:55 , fredycayo dijo:

Buen día,

Agradezco por el tiempo, es valor de la columna A

BF1...

PC1...

PRD...

PDR..

Hola, 

Todo lo que empieza por B es 0,2? ¿Todo lo que comienza por PC es 0,6? ¿Habría más valores aparte de los que aparecen en tu ejemplo?

[fredycayo]

Muy buenas tardes. si Rampa= RP Las rampas tiene una inclinación por porcentajes y estos no son fijos y cambian constantemente desde 1 cm hasta los 6 mts. solo quiero trabajar con los que tienen valores fijos.

Agradezco su tiempo.

Saludos.

[dogwall]

Hola, 

Iba a subir tu archivo con el código que he añadido, pero no tengo claro cómo hacerlo.  De todas formas te explico:

Añade esta función a tú código, en cualquier módulo (está sacada de StackOverflow) que sirve para extraer números de una cadena de texto:

Function onlyDigits(s As String) As String
    ' Variables needed (remember to use "option explicit").   '
    Dim retval As String    ' This is the return string.      '
    Dim i As Integer        ' Counter for character position. '

    ' Initialise return string to empty                       '
    retval = ""

    ' For every character in input string, copy digits to     '
    '   return string.                                        '
    For i = 1 To Len(s)
        If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then
            retval = retval + Mid(s, i, 1)
        End If
    Next

    ' Then return the return string.                          '
    onlyDigits = retval
End Function

Ahora añade este módulo, que es el que hace todo el trabajo:

Sub calcular()

    Dim i As Long, uf As Long, x As Long
    Dim sht As Worksheet
    Dim cota As Double, profundidad As Double
    Dim calculoH As String, calculoI As Double, TipoValor As Double
    Dim calculoG As Integer
    Dim NPunto As String
    Dim arrDatos As Variant, arrReport As Variant
        
    Set sht = ThisWorkbook.Sheets("Hoja1")
    uf = sht.Cells(Rows.Count, "A").End(xlUp).Row
    arrDatos = sht.Range("A2:D" & uf)
    
    sht.Range("N2:S" & uf).ClearContents
    
    ReDim arrReport(0 To UBound(arrDatos), 5)
    x = 0
    For i = 1 To UBound(arrDatos)
    
        calculoH = Left(arrDatos(i, 1), 2)
    
        Select Case calculoH
        
        Case Is = "BF": TipoValor = 0.2
        Case Is = "PC": TipoValor = 0.6
        Case Is = "PR": TipoValor = 0.8
        Case Is = "PD": TipoValor = 0.8
                
        End Select
        
        NPunto = arrDatos(i, 1)
        arrReport(x, 0) = onlyDigits(NPunto)    'Nº de Punto
        arrReport(x, 1) = arrDatos(i, 2)        'ESTE
        arrReport(x, 2) = arrDatos(i, 3)        'NORTE
        arrReport(x, 3) = arrDatos(i, 4)        'COTA
        calculoG = Application.WorksheetFunction.Round(arrDatos(i, 4), 0) - 6
        calculoI = arrDatos(i, 4) - (CInt(calculoG) - TipoValor)
        arrReport(x, 4) = calculoI              'PROFUNDIDAD
        arrReport(x, 5) = arrDatos(i, 1)        'CODIGO
        x = x + 1
        
    Next i

    sht.Range("N2").Resize(UBound(arrReport), 6) = arrReport

End Sub

Y por último asocia tú botón "Cálculo"  a esa macro (calcular). La macro borra el rango N2:S & ultima fila y añade los cálculos en base a tu tabla.

Saludos.

 

[fredycayo]

Estimado Dogwall.

Muy agradecido por tu atención a mi problema funciona perfectamente, solucionado