Macro para calculo de irregularidad torsional

Para subir hojas de calculo de Ingenieria civil
Reglas del Foro
Favor de usar el boton de Dar Gracias
En el mensaje del usuario al que deseas agradecer
En vez de escribir gracias repetidamente
programadordemacros
Usuario Principiante
Usuario Principiante
Mensajes: 2
Registrado: Vie Dic 10, 2021 11:53 pm
Contactar:
Colombia

Soy Proveedor de una Macro para calculo de irregularidad torsional.
Mi nombre es Carlos Felipe Orejarena Betancurt. Gerente de Proyectos de Cubo Sistemas.
Esta macro es una automatización realizada
con la ayuda de un Ingeniero Civil para su uso diario.

Para mayores informes, Por favor envíeme un correo a: programadordemacros@gmail.com
Somos creadores de soluciones en Microsoft Excel.
Facebook e Instagram: programadormacros
Llámame: +57 312 267 81 61 Carlos. Gracias,

Puedo hacerle una demostración de la macro en funcionamiento, es muy útil ya que ahorra tiempo
de trabajo para el calculo de irregularidad torsional.

Descripción del Proyecto. Solución en Microsoft Excel con Macros y Visual Basic

Macro de Cálculo de Irregularidad Torsional (Los 3 Botones)
- BOTÓN 0: "Nuevo". Sirve para dejar la solución en un estado inicial. Es decir se borra la información,
pero respeta una estructura base.
- BOTON 1: Un segundo botón forma el cuerpo y la estructura de la solución. Macro en Microsoft Excel.
- BOTÓN 3: Un tercer botón se encarga de ejecutar un algoritmo que tiene instrucciones para ejecución de
formulas de Microsoft Excel que van en la estructura que se forma con el botón 1.
- Es decir, no hay que hacerlo manual. La solución se forma con 3 Botones. según unos datos de entrada
que se proporcionan a Trávez de un InputBox.
- Los datos que se proporcionan de entrada son: 1: Número de Niveles y 2: Número de Columnas
- Datos de entrada que reciben unas variables programadas en Visual Basic.

Datos que forman la solución:
-Niveles
- Cubierta
- Columna
- Deriva x reportada por C YP E
- Deriva y reportada por C YP E
- Deriva x
- Deriva y
- 0.80 Deriva x
- 0.65 Deriva x
- ɸax
- 0.80 Deriva y
- 0.65 Deriva y
- ɸay


Código Fuente que hay en cada boton.

Código Fuente Botón: Formulas



'ON ERROR GO TO
Dim v As Integer
v = 0

'Abrir columnas
For v = 1 To 2
Range("F15").Select
Columns("F:F").Select
ActiveCell.EntireColumn.Insert

Next v

'Contar el numero de columnas
Dim v1, v2, v3, v4, v5 As Integer
v4 = 16
v5 = 0

'Contar el numero de filas
v1 = 0
v2 = 16
v3 = 1

'Alimentar la vble con el dato de entrada. Se usa un InputBox
Dim num_niveles_2 As Integer
num_niveles_2 = Application.InputBox("Número de Niveles")

While Cells(v4, 2) <> Empty

v1 = v1 + 1
'Extraer el digito. Estructura 1
Cells(v4, 6).Select

If Cells(v4, 4) = Empty Then
GoTo 2
Else


ActiveCell.FormulaR1C1 = "=RIGHT(RC[-2],3)"
Cells(v4, 7).Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-2],3)"
'-------------------------------------------

'Poner los unos estructura 1
Cells(v4, 4) = "1/" & Cells(v4, 6).Value
Cells(v4, 4).Select
Cells(v4, 5) = "1/" & Cells(v4, 7).Value
Cells(v4, 5).Select
'--------------------------------

'oN ERROR GO TO
'Derivada X y Y. Columna 1
Cells(v4, 8) = 1 / Cells(v4, 6) 'Derivada x
Cells(v4, 9) = 1 / Cells(v4, 7) 'Derivada y
'-------------------------------------------

2
End If
v4 = v4 + 1
Wend
'-----------------------------------------------------

'Cerrar columnas

Dim v40 As Integer
For v40 = 1 To 2
Range("F15").Select
ActiveCell.EntireColumn.delete

Next v40

'Las formulas podrian alterarse por este cambio
'asi que abría que adaptarlas al despues de eliminar columnas

'-----------------------------------------------------------------------------------


'Eje X Estructura 1
Dim v6 As Integer
v6 = 16

Dim v7 As Integer
v7 = 17
v7 = v7 + num_niveles_2

While Cells(v6, 2) <> Empty

If Cells(v6, 4) = Empty Then
GoTo 3
Else

Cells(v6, 8).Select
ActiveCell.FormulaR1C1 = "=+((R[5]C[-2]+RC[-2])/2)*1.4" 'Calculo del ejeX
Cells(v6, 9).Select
ActiveCell.FormulaR1C1 = "=+((R[5]C[-3]+RC[-3])/2)*1.2" 'Calculo del ejeX
3
End If
v7 = v7 + 1
v6 = v6 + 1
Wend
'------------------------------------------------------------------------------------

'Limpiar datos ejex
Dim v8 As Integer
v8 = 17
v8 = v8 + num_niveles_2

Cells(v8).Select
While Cells(v8, 2) <> Empty

Cells(v8, 8).Select
Cells(v8, 8) = ""
Cells(v8, 9) = ""

v8 = v8 + 1
Wend
'------------------------------------------------------------------

'Calculo OPX
Dim v9 As Integer
v9 = 16
While Cells(v9, 2) <> Empty

If Cells(v9, 4) = Empty Then
GoTo 4
Else

Cells(v9, 10).Select
ActiveCell.FormulaR1C1 = "=+IF(RC[-4]>=RC[-2],0.8,IF(RC[-4]>RC[-1],0.9,1))"

4
End If
v9 = v9 + 1
Wend
'------------------------------------------------------------------

'Limpiar datos OPX
Dim v10 As Integer
v10 = 17
v10 = v10 + num_niveles_2

Cells(v10).Select
While Cells(v10, 2) <> Empty

Cells(v10, 10).Select
Cells(v10, 10) = ""

v10 = v10 + 1
Wend
'------------------------------------------------------------------

'Calculo EJE Y Estructura 1
Dim v11 As Integer
v11 = 16

Dim v12 As Integer
v12 = 17
v12 = v12 + num_niveles_2

While Cells(v11, 2) <> Empty

If Cells(v11, 4) = Empty Then
GoTo 5
Else


Cells(v11, 11).Select
ActiveCell.FormulaR1C1 = "=+((RC[-4]+R[5]C[-4])/2)*1.4"
Cells(v11, 12).Select
ActiveCell.FormulaR1C1 = "=+((RC[-5]+R[5]C[-5])/2)*1.2" 'Calculo del ejey

5
End If
v11 = v11 + 1
v12 = v12 + 1
Wend
'------------------------------------------------------------------------------------

'Limpiar datos ejeY
Dim v13 As Integer
v13 = 17
v13 = v13 + num_niveles_2

Cells(v13).Select
While Cells(v13, 2) <> Empty

Cells(v13, 11).Select
Cells(v13, 11) = ""
Cells(v13, 12) = ""

v13 = v13 + 1
Wend
'------------------------------------------------------------------

'CALCULO OPY
Dim v14 As Integer
v14 = 16
While Cells(v14, 2) <> Empty


If Cells(v14, 4) = Empty Then
GoTo 6
Else

Cells(v14, 13).Select
ActiveCell.FormulaR1C1 = "=+IF(RC[-6]>=RC[-2],0.8,IF(RC[-6]>RC[-1],0.9,1))"

End If
6

v14 = v14 + 1
Wend
'------------------------------------------------------------------


'Limpiar datos OPY
Dim v15 As Integer
v15 = 17
v15 = v15 + num_niveles_2

Cells(v15).Select
While Cells(v15, 2) <> Empty

Cells(v15, 13).Select
Cells(v15, 13) = ""

v15 = v15 + 1
Wend
'------------------------------------------------------------------



'Abrir columnas
Dim b1 As Integer
For b1 = 1 To 2
Range("F15").Select
Columns("F:F").Select
ActiveCell.EntireColumn.Insert

Next b1
'-------------------------------------------------------------------

'ESTRUCTURA 2
'Posicionamiento en Cubierta
Dim v16, v17 As Integer
v16 = 16
v17 = Cells(v16, 17)
Cells(v17, 2).Select 'Me posiciono
v17 = v17 + 3 'Sumo 3 para posicionarlo en cubierta
Cells(v17, 2).Select 'Me posiciono en cubierta
'-----------------------------------------------------------

While Cells(v17, 2) <> Empty

If Cells(v17, 4) = Empty Then
GoTo 7
Else

'Extraer el digito. Estructura 2
Cells(v17, 6).Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-2],3)"
Cells(v17, 7).Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-2],3)"
'-------------------------------------------

'Poner los unos estructura 2
Cells(v17, 4) = "1/" & Cells(v17, 6).Value
Cells(v17, 4).Select
Cells(v17, 5) = "1/" & Cells(v17, 7).Value
Cells(v17, 5).Select
'--------------------------------

'oN ERROR GO TO
'Derivada X y Y. Columna 1
Cells(v17, 8) = 1 / Cells(v17, 6) 'Derivada x
Cells(v17, 9) = 1 / Cells(v17, 7) 'Derivada y
'-------------------------------------------

End If
7

v17 = v17 + 1
Wend
'-----------------------------------------------------

'Cerrar columnas
Dim b2 As Integer
For b2 = 1 To 2
Range("F15").Select
ActiveCell.EntireColumn.delete

Next b2
'-----------------------------

'CÁCLCULO EJE X ESTRUCTURA 2

'Me posiciono en Cubierta
Dim v19, v20 As Integer
v19 = 16
v20 = Cells(v19, 15)
Cells(v20, 2).Select 'Me posiciono
v20 = v20 + 3 'Sumo 3 para posicionarlo en cubierta
Cells(v20, 2).Select 'Me posiciono en cubierta
'------------------------------------------------------------------

'Me posiciono en Nivel 1
Dim v18 As Integer
v18 = Cells(v16, 15)
Cells(v18, 2).Select 'Me posiciono
v18 = v18 + 4 'Sumo 4 para posicionarlo en Nivel1
Cells(v18, 2).Select 'Me posiciono en nivel 1
v18 = v18 + num_niveles_2
Cells(v18, 2).Select 'Me posiciono
'-------------------------------------------------------------------


While Cells(v20, 2) <> Empty

If Cells(v20, 4) = Empty Then
GoTo 8
Else
Cells(v20, 8).Select
ActiveCell.FormulaR1C1 = "=+((R[5]C[-2]+RC[-2])/2)*1.4" 'Calculo del ejeX 'Calculo del ejeX
Cells(v20, 9).Select
ActiveCell.FormulaR1C1 = "=+((R[5]C[-3]+RC[-3])/2)*1.2" 'Calculo del ejeX

End If
8

v18 = v18 + 1
v20 = v20 + 1
Wend
'------------------------------------------------------------------------------------


'Limpiar datos ejeX
Dim v21 As Integer
v21 = v21 + num_niveles_2

'1. Me posiciono
v21 = Cells(v16, 15)
Cells(v21, 2).Select 'Me posiciono
v21 = v21 + 4 'Sumo 4 para posicionarlo en Nivel1
Cells(v21, 2).Select 'Me posiciono en nivel 1
v21 = v21 + num_niveles_2
Cells(v21, 2).Select 'Me posiciono
'---------------------------------------------------------

'2. Limpio
Cells(v21).Select
While Cells(v21, 2) <> Empty

Cells(v21, 8).Select
Cells(v21, 8) = ""
Cells(v21, 9) = ""

v21 = v21 + 1
Wend
'------------------------------------------------------------------

'Calculo OPX Estructura 2

'Posicionamiento en Cubierta
Dim v22, v23 As Integer
v22 = 16
v23 = Cells(v22, 15)
Cells(v23, 2).Select 'Me posiciono
v23 = v23 + 3 'Sumo 3 para posicionarlo en cubierta
Cells(v23, 2).Select 'Me posiciono en cubierta
'-----------------------------------------------------------


While Cells(v23, 2) <> Empty

If Cells(v23, 4) = Empty Then
GoTo 9
Else

Cells(v23, 10).Select
ActiveCell.FormulaR1C1 = "=+IF(RC[-4]>=RC[-2],0.8,IF(RC[-4]>RC[-1],0.9,1))"

End If
9
v23 = v23 + 1
Wend
'------------------------------------------------------------------

'Limpiar datos OPX

'Me posiciono en Nivel 1
Dim v24 As Integer
v24 = Cells(v16, 15) 'v16 es una variable de control para posicionarme
Cells(v24, 2).Select 'Me posiciono
v24 = v24 + 4 'Sumo 4 para posicionarlo en Nivel1
Cells(v24, 2).Select 'Me posiciono en nivel 1
v24 = v24 + num_niveles_2
Cells(v24, 2).Select 'Me posiciono

Cells(v24).Select
While Cells(v24, 2) <> Empty

Cells(v24, 10).Select
Cells(v24, 10) = ""

v24 = v24 + 1
Wend
'------------------------------------------------------------------

'Calculo EJE Y Estructura 2
'1. Posicionamiento en cubierta

'Posicionamiento en Cubierta
Dim v25, v26 As Integer
v25 = 16
v26 = Cells(v25, 15)
Cells(v26, 2).Select 'Me posiciono
v26 = v26 + 3 'Sumo 3 para posicionarlo en cubierta
Cells(v26, 2).Select 'Me posiciono en cubierta
'-----------------------------------------------------------

' Posicionamiento en Nivel 1
Dim v27 As Integer
v27 = Cells(v16, 15) 'v16 es una variable de control para posicionarme
Cells(v27, 2).Select 'Me posiciono
v27 = v27 + 4 'Sumo 4 para posicionarlo en Nivel1
Cells(v27, 2).Select 'Me posiciono en nivel 1
v27 = v27 + num_niveles_2
Cells(v27, 2).Select 'Me posiciono
'-----------------------------------------------------------------

While Cells(v26, 2) <> Empty

If Cells(v26, 4) = Empty Then
GoTo 10
Else

Cells(v26, 11).Select
ActiveCell.FormulaR1C1 = "=+((RC[-4]+R[5]C[-4])/2)*1.4"
Cells(v26, 12).Select
ActiveCell.FormulaR1C1 = "=+((RC[-5]+R[5]C[-5])/2)*1.2" 'Calculo del ejey

End If
10

v26 = v26 + 1
v27 = v27 + 1
Wend
'------------------------------------------------------------------------------------

'Limpiar datos ejeY
'1. Me posiciono

'Me posiciono en Nivel 1
Dim v28 As Integer
v28 = Cells(v16, 15) 'v16 es una variable de control para posicionarme
Cells(v28, 2).Select 'Me posiciono
v28 = v28 + 4 'Sumo 4 para posicionarlo en Nivel1
Cells(v28, 2).Select 'Me posiciono en nivel 1
v28 = v28 + num_niveles_2
Cells(v28, 2).Select 'Me posiciono
'------------------------------------------------------------------


'Limpiar los datos
Cells(v28).Select
While Cells(v28, 2) <> Empty

Cells(v28, 11).Select
Cells(v28, 11) = ""
Cells(v28, 12) = ""

v28 = v28 + 1
Wend
'------------------------------------------------------------------



'CALCULO OPY Estructura2

'Posicionamiento en Cubierta
Dim v29, v30 As Integer
v29 = 16
v30 = Cells(v29, 15)
Cells(v30, 2).Select 'Me posiciono
v30 = v30 + 3 'Sumo 3 para posicionarlo en cubierta
Cells(v30, 2).Select 'Me posiciono en cubierta
'-----------------------------------------------------------


While Cells(v30, 2) <> Empty

If Cells(v30, 4) = Empty Then
GoTo 11
Else

Cells(v30, 13).Select
ActiveCell.FormulaR1C1 = "=+IF(RC[-6]>=RC[-2],0.8,IF(RC[-6]>RC[-1],0.9,1))"

End If
11
v30 = v30 + 1
Wend
'------------------------------------------------------------------


'Limpiar datos OPY

'Me posiciono en Nivel 1
Dim v31 As Integer
v31 = Cells(v16, 15) 'v16 es una variable de control para posicionarme
Cells(v31, 2).Select 'Me posiciono
v31 = v31 + 4 'Sumo 4 para posicionarlo en Nivel1
Cells(v31, 2).Select 'Me posiciono en nivel 1
v31 = v31 + num_niveles_2
Cells(v31, 2).Select 'Me posiciono

Cells(v31).Select
While Cells(v31, 2) <> Empty

Cells(v31, 13).Select
Cells(v31, 13) = ""

v31 = v31 + 1
Wend
'------------------------------------------------------------------




End Sub





1 Botón Nuevo:

'Borrar los datos 1
Range("B16:M16").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("B16").Select
'-------------------------------------------------------

'Quitar los bordes1

Range("B18:M19").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("B16").Select

'-------------------------------------------------------

'Llevar valores alfanuméricos a las celdas
Sheets("1aP-1bP").Select
Range("B16").Select
hh = 16
Cells(hh, 16).Select ' Me posiciono
Cells(hh, 2) = "Cubierta" 'Asigno valor alfanumérico
hh = hh + 1 'Sumo
Cells(hh, 2) = "Cubierta" 'Asigno valor alfanumérico


'Bordes

Range("B16:M16").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("B16").Select

'-------------------------------------------------

'On error goto
On Error GoTo errHandler
'Borrar los datos 2
Dim j1, j2, j3, j4 As Integer
j1 = 16
j2 = Cells(j1, 15) 'Tomar digito de control
j3 = 0 'Inicializar vble del ciclo para
Cells(j2, 2).Select 'Posicionar según el valor del digito de control


While Cells(j2, 2) <> Empty
For j3 = 1 To j2
Selection.delete Shift:=xlUp
Next j3
j2 = j2 + 1
Wend

Cells(j1, 2).Select
Cells(j1, 15) = 0

Exit Sub

errHandler:
MsgBox "Los datos ya fueron borrados"

End Sub

Código Fuente Botón: Cuerpo y Estructura

2. ​Cuerpo y estructura



Sub B_cuerpo_y_estructura()

'Primero hay que consruir el cuerpo
'El cuerpo me arroja una data para calcular
'la dimensión de toda la estructura
'Ubicarme en la hoja específica. 1aP-1bp
Sheets("1aP-1bP").Select
'Dato de entrada
Dim i, j, n, b As Integer
'Dim insertar As String
n = 17 ' Me posiciono en Cubierta 1
b = 18 ' Me posiciono en Cubierta 1
i = 1 'Inicializar variable
j = 1 'Inicializar variable
'Alimentar la vble con el dato de entrada. Se usa un InputBox
num_niveles_2 = Application.InputBox("Número de Niveles")

'COMIENZO CON EL CUERPO DEL CUADRO
For i = 1 To num_niveles_2
Cells(n, 2).Select 'Posicionarme en la celda para insertar
ActiveCell.EntireRow.Insert
Cells(n, 2) = "Nivel" & i
n = n + 1
b = b + 1
Next i

For j = 1 To num_niveles_2
Cells(b, 2).Select 'Posicionarme en la celda para insertar
ActiveCell.EntireRow.Insert
Cells(b, 2) = "Nivel" & j
n = n + 1
b = b + 1
Next j
'----------------------------------------------------------------

'Colocar los nombres de las columnas
Dim p1, p2 As Integer
p1 = 16
p2 = 0
While Cells(p1, 2) <> Empty

If Cells(p1, 2) = "Cubierta" Then
p2 = p2 + 1
Cells(p1, 3) = "C" & p2

End If

p1 = p1 + 1
Wend


'Bordes

Range("B16:M16").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("B16").Select
'------------------------------------------------------------------------------------

'Llevar valor de cero al digito de control
Dim ad As Integer
ad = 16
Cells(ad, 15) = 0
'Esto lo debo hacer en caso tal de solo
'evaluar con una estructura, esto lo valido
'con un Yes,No, Cancel
'Si tiene dos Cells ad,15=1
'Sino, ad,15=0
'Con este resultado, controlo o genero la
'formula
'------------------------------------------

'Estructura 2
Dim zhc, cont1 As Integer
zhc = 16
cont1 = 0

While Cells(zhc, 2) <> Empty

cont1 = cont1 + 1

zhc = zhc + 1
Wend

zhc = zhc + 5


Range("B16:M16").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

Cells(zhc, 2).Select
ActiveSheet.Paste


Dim zh, cont, zhh As Integer
zh = 16
zhh = 16
cont = 0
While Cells(zh, 2) <> Empty

cont = cont + 1

zh = zh + 1
Wend

zh = zh + 2
Cells(zh, 2).Select
Cells(zhh, 15) = zh 'Digito de control

Range("B13:M15").Select
Selection.Copy


Cells(zh, 2).Select
ActiveSheet.Paste
Range("B14:B15").Select





If z = 500 Then
Exit Sub
End If



'Retomar



End Sub


Muchas Gracias.
Estamos ubicados en Medellín - Colombia
calculo_de_irregularidad_torsional.jpg
No tienes los permisos requeridos para ver los archivos adjuntos a este mensaje.
Responder
  • Similar Topics
    Respuestas
    Vistas
    Último mensaje

Volver a “Hojas de Calculo Excel”

  • Información