GAUSS JORDAN EN EXCEL Matrices con codigo en excel con macros

GAUSS JORDAN EN EXCEL 

Código de la aplicación en la parte final de este artículo

 

https://www.youtube.com/watch?v=J3GPUhaSdxU


http://borradoresalfonso.blogspot.com.co/2015/01/gauss-jordan-en-visual-basic-de-excel.html

La hoja de excel quedaría de la siguiente forma:

Ahora hacemos click sobre el botón, o combinamos las teclas "Ctrl + h", y nos saldrá la ventana siguiente:

Elegimos el Nro de filas que en nuestro caso son "5"    *(1-5)

elegimos el Nro de columnas que en nuestro caso son "6"    *(A-F)

y presionamos el boton "REDUCCION GAUSS"

Y obtenemos la matriz en su forma escalonada reducida. como muestra la siguiente figura, debidamente demarcada:

El sistema ha sido probado ampliamente con la mayoria de casos donde podría haber error y ha sido satisfecho cualquier examen.

Esperamos sea de utilidad.

***(si al hacer click en el link de descarga le aparece publicidad cierre y vuelva a intentarlo)***

PUEDES BAJARTE LA HOJA DE EXCEL GRATIS QUE CONTIENE LA APLICACIÓN CLICK AQUI

Haz click en este link para descargar la hoja de excel gratis-->> 

 DESCARGAR GAUSS JORDAN EN EXCEL

Código de la aplicación


/////////////////////////////////////////////////////
Sub form()
ActiveSheet.Range("A1").Select
frmgauss.Show

End Sub


Sub gauss()
'
' gauss Macro
' abre el reductor de matrices gauss Jordan
'
' Acceso directo: CTRL+h
'
    ActiveSheet.Range("A1").Select
frmgauss.Show
End Sub

//////////////////////////////////////////////////////////



'///////////////////////////////////////////////////////////////////////////////////////////////////////////////
'******************************
'GAUSS JORDAN
'REDUCCION MATRICIAL NXN
'DESARROLLADO POR JOSE ARIVILCA
'CIPRODIQ - IQ UNSA
'2014
'PARA: VBX DESARROLLO
'UNSA 2014
'*******************************
Option Explicit
Dim ct As Double
Dim ft As Double
Dim a As Double
Dim c As Double
Dim f As Double
Dim fx As Double
Dim piv As Double
Dim cmc As Double
Dim varx As Double
Dim divs As Double
Dim rc As Double
Dim rf As Double

Private Sub cbocol_Change()

End Sub

Private Sub cmdcreditos_Click()
MsgBox "REDUCCION DE GAUSS" & vbCrLf & "programado por JOSE ALFONSO ARIVILCA" & vbCrLf & "VBX DESARROLLO 2015" & vbCrLf & "jose_alfonso@peru.com / pjose_alfonso@hotmail.com", vbInformation, "Acerca de..."
End Sub

Private Sub cmdmatriz_Click()

If cbofil.Text <> Empty Then
    If cbocol.Text <> Empty Then
        completar
        inicio_gauss
        seleccionar
        frmgauss.Hide
        MsgBox "La reducción de gauss ha concluido", vbInformation, "VBX DESARROLLO 2015"
        Unload Me
    Else
        MsgBox "Ingrese el numero de filas y columnas del sistema", vbCritical, "Datos necesarios"
        cbocol.SetFocus
    End If
Else
    MsgBox "Ingrese el numero de filas y columnas del sistema", vbCritical, "Datos necesarios"
    cbofil.SetFocus
End If
End Sub
Sub completar()
Dim cdfil As Double
Dim cdcol As Double
For cdcol = 1 To CDbl(cbocol.Text)
    For cdfil = 1 To CDbl(cbofil.Text)
        If Not IsNumeric(Cells(cdfil, cdcol).Value) Then
            Cells(cdfil, cdcol).Value = "0"
        End If
        If (Cells(cdfil, cdcol).Value) = Empty Then
            Cells(cdfil, cdcol).Value = "0"
        End If
    Next cdfil
Next cdcol
End Sub
Sub inicio_gauss()
ct = CDbl(cbocol.Text)
ft = CDbl(cbofil.Text)

a = 1
For c = 1 To ct
    For f = a To ft
        fx = a
        piv = CDbl(Cells(f, c).Value)
        If piv <> 0 Then
            If a <> f Then
                cambiar_filas
                f = fx
                reducir_gauss
                a = fx + 1
                Exit For
            Else
                reducir_gauss
                a = fx + 1
                Exit For
            End If
        Else
            If f = ft Then
                a = fx
            End If
        End If
    Next f
    If c = ct - 1 Then
        Exit For
    End If
Next c
End Sub

Sub cambiar_filas()

For cmc = 1 To ct
    varx = Cells(f, cmc).Value
    Cells(f, cmc).Value = Cells(fx, cmc).Value
    Cells(fx, cmc).Value = varx
Next cmc
   
End Sub

Sub reducir_gauss()
Dim redx As Double

If c < ct Then
    For divs = c + 1 To ct
        Cells(f, divs).Value = "=" & Cells(f, divs).Value & "/" & Cells(f, c).Value
    Next divs
    Cells(f, c).Value = "=" & Cells(f, c).Value & "/" & Cells(f, c).Value
End If

   
   
   
If f < ft Then
    If c < ct Then
        For rc = c + 1 To ct
            For rf = f + 1 To ft
                Cells(rf, rc).Value = "=-1*" & Cells(rf, c).Value & "*" & Cells(f, rc).Value & "+" & Cells(rf, rc).Value
            Next rf                            'constante
           
        Next rc
        For redx = f + 1 To ft
                Cells(redx, c).Value = "=0"
        Next redx
    End If
End If

If f > 1 Then
    If c < ct Then
        For rc = c + 1 To ct
            For rf = f - 1 To 1 Step -1
                Cells(rf, rc).Value = "=-1*" & Cells(rf, c).Value & "*" & Cells(f, rc).Value & "+" & Cells(rf, rc).Value
            Next rf
        Next rc
        For redx = f - 1 To 1 Step -1
                Cells(redx, c).Value = "=0"
        Next redx
    End If
End If

End Sub





Private Sub UserForm_Initialize()
Dim numb As Double
cbofil.Clear
cbocol.Clear
For numb = 2 To 1000
    cbofil.AddItem numb
    cbocol.AddItem numb
Next numb
End Sub


Sub seleccionar()
'*borramos cualquier linea en nuestra area de trabajo*****************
Range(Cells(1, 1), Cells(CDbl(cbofil.Text), CDbl(cbocol.Text))).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
'*********************************************************************
'ponemos en recuadro nuestra matriz
   Range(Cells(1, 1), Cells(CDbl(cbofil.Text), CDbl(cbocol.Text))).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
   
   '** ahora ponemos en cuadro nuestros resultados de variables
  
    Range(Cells(1, 1), Cells(CDbl(cbofil.Text), CDbl(cbocol.Text) - 1)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("A1").Select
End Sub





'//////////////////////////////////////////////////////////////////////////////////////////////////