INGENIERÍA & BURÓTICA

Tema 1: Obtener un valor asociado al máximo dentro de una categoría  Tema 2: Unir valores por cada categoría Tema 3: Dividir una columna por delimitador en fila Tema 4: Ranking por categoría  Tema 5: Dividir nombre, segundo nombre y apellido Tema 6: Unir filas relacionadas  Tema 7: Contar valores de una columna con mas de un valor Tema 8: Filtrar según una categoría y una condición Tema 9: Valores únicos de dos listas  Tema 10: U

Código Sub Insertar·Columnas·Filas·Intercaladas() Dim Ws As Worksheet, Rng As Range, fc As String Dim J As Integer, O As Integer, R As Integer, G As Integer, E As Integer, i As Integer Set Ws = ActiveSheet fc = InputBox("C para insertar columnas o F para insertar filas") fc = UCase(fc) If fc <> "F" And fc <> "C" Then MsgBox "Debes ingresar C para columnas o F para filas.", vbExclamation, "Error" Exit Sub End If On Error Resume Next Set Rng = Application.InputBox("Selecciona el rango donde se insertarán las " & IIf(fc = "F", "Filas", "Columnas"), Type:=8) On Error GoTo 0 If Rng Is Nothing Then MsgBox "No seleccionaste un rango válido.", vbExclamation, "Error" Exit Sub End If J = InputBox("¿Cada cuántas " & IIf(fc = "F", "Filas", "Columnas") & "?") If Not IsNumeric(J) Or J <= 0 Then MsgBox "Debes in...

Código Function SubtotalesColumnas(Funcion As Integer, ParamArray Rangos() As Variant) As Variant Application.Volatile Dim C As Range, J As Double, O As Double, Vlr() As Double, R As Long, G As Long, E As Long, Rng As Variant J = 0 O = 1 R = 0 G = 0 E = 0 On Error GoTo ManejoError For Each Rng In Rangos If TypeOf Rng Is Range Then For Each C In Rng If Not C.EntireColumn.Hidden Then If Not IsEmpty(C.Value) Then If IsNumeric(C.Value) Then E = E + 1 J = J + C.Value O = O * C.Value ReDim Preserve Vlr(R) Vlr(R) = C.Value R = R + 1 End If G = G + 1 End If End If Next C Else SubtotalesColumnas = CVErr(xlErrValue) Exit Function End If Next Rng Select Case Funcion Case 1 If E > 0 Then SubtotalesColumnas = WorksheetFunction.Average(Vlr) Else SubtotalesColumnas = CVErr(xlErrDiv0) End If Case 2 SubtotalesColumnas = E Case 3 SubtotalesColumnas = G Case 4 If E > 0 Then SubtotalesColumnas = WorksheetFunction.Max(Vlr) Else SubtotalesColumnas = CVErr(xlErrNum) End If Case 5 If E > 0 Then Subto...

Código Function NumSemMes(Fecha As Date, DiaInicio As Integer) As Integer    NumSemMes = WorksheetFunction.WeekNum(Fecha, DiaInicio) - WorksheetFunction.WeekNum(Fecha - Day(Fecha) + 1, DiaInicio) + 1 End Function La codificación numérica para el argumento "DiaInicio" (día de inicio de la semana) es el mismo que de la función NUM.DE.SEMANA

Código UDF Function Fecha·Normal·a·Juliana·Viceversa(ByVal Fecha As Variant, Optional Ingrese·1·para·Juliana·a·Normal As Boolean = False) As Variant Dim A As Integer, D As Integer, FN As Date If Ingrese·1·para·Juliana·a·Normal Then A = Left(Fecha, 4) D = Right(Fecha, Len(Fecha) - 4) On Error Resume Next FN = DateSerial(A, 1, D) On Error GoTo 0 If IsDate(FN) Then Fecha·Normal·a·Juliana·Viceversa = FN Else Fecha·Normal·a·Juliana·Viceversa = CVErr(xlErrValue) End If Else If IsDate(Fecha) Then A = Year(Fecha) D = Fecha - DateSerial(A, 1, 0) Fecha·Normal·a·Juliana·Viceversa = A & Format(D, "000") Else Fecha·Normal·a·Juliana·Viceversa = CVErr(xlErrValue) End If End If End Function Código Procedimiento Sub Convertir·Fecha·Normal·a·Juliana·Viceversa() Dim RE As Range, RS As Range, C As Range, F As Variant, M As Variant, A As Integer, D As Integer, FN As Date, R As Variant On Error Resume Next Set RE = Application.InputBox("Seleccione el rango que contiene las Fechas Normales...

Código Function IB·ExtraerLetraNumero(Texto As String, Optional ByVal Ingrese1paraObtenerLosNumeros As String = "0") As String Dim x As String, I As Integer, c As Integer For I = 1 To Len(Texto) c = Asc(Mid(Texto, I, 1)) If Ingrese1paraObtenerLosNumeros = "1" Then If c >= 48 And c <= 57 Then x = x & Mid(Texto, I, 1) End If Else Select Case c Case 193, 201, 205, 211, 218, 209, 225, 233, 237, 243, 250, 241 x = x & Mid(Texto, I, 1) Case 65 To 90, 97 To 122 x = x & Chr(c) End Select End If Next I IB·ExtraerLetraNumero = x End Function

Código Sub IB·InsertarComentarios() Dim R As Range, C As Range, I As Range, B As Comment On Error Resume Next Set R = Application.InputBox("Selecciona el rango de celdas cuyos valores se utilizarán como comentarios:", "INGENIERÍA & BURÓTICA", Type:=8) On Error GoTo 0 If R Is Nothing Then Exit Sub On Error Resume Next Set C = Application.InputBox("Selecciona el rango de celdas donde se insertarán los comentarios:", "INGENIERÍA & BURÓTICA", , Type:=8) On Error GoTo 0 If C Is Nothing Then Exit Sub For Each I In C If Not IsEmpty(R.Cells(I.Row - C.Rows(1).Row + 1, I.Column - C.Columns(1).Column + 1).Value) Then Set B = I.AddComment(R.Cells(I.Row - C.Rows(1).Row + 1, I.Column - C.Columns(1).Column + 1).Value) End If Next I MsgBox "Los comentarios se han insertado correctamente.", , "INGENIERÍA & BURÓTICA" End Sub

Código Function IB·ValorFrecuente(Rango As Range, Optional Ingrese·1·para·obtener·el·Valor·Infrecuente As Variant = 0) As Variant Dim x As Object, y As Range, l As Variant, m As Long, n As String Set x = CreateObject("Scripting.Dictionary") If Ingrese·1·para·obtener·el·Valor·Infrecuente = 0 Then For Each y In Rango If Not IsEmpty(y.Value) Then If Not x.Exists(y.Value) Then x.Add y.Value, 1 Else x(y.Value) = x(y.Value) + 1 End If If x(y.Value) > m Then m = x(y.Value) n = y.Value ElseIf x(y.Value) = m Then n = n & "; " & y.Value End If End If Next y If Len(n) > 0 Then IB·ValorFrecuente = n Else IB·ValorFrecuente = "" End If ElseIf Ingrese·1·para·obtener·el·Valor·Infrecuente = 1 Then For Each y In Rango l = y.Value If Not IsEmpty(l) Then If x.Exists(l) Then x(l) = x(l) + 1 Else x.Add l, 1 End If End If Next y m = Application.WorksheetFunction.Min(x.Items) For Each l In x If x(l) = m Then If n = "" Then n = l Else n = n & "; ...

Código Private Sub Worksheet_Change(ByVal Target As Range) Dim t As ListObject, F As Long, IB_JMMA As Range Set t = Me.ListObjects("") F = t.HeaderRowRange.Row Set IB_JMMA = Intersect(Target, t.ListColumns("").DataBodyRange) If Not IB_JMMA Is Nothing Then If IB_JMMA.Value <> "" Then With t.ListColumns("").DataBodyRange If .Cells(IB_JMMA.Row - F).Value = "" Then .Cells(IB_JMMA.Row - F).Value = Format(Now, "mm/dd/yyyy") End If End With With t.ListColumns("").DataBodyRange If .Cells(IB_JMMA.Row - F).Value = "" Then .Cells(IB_JMMA.Row - F).Value = Format(Now, "hh:mm:ss") End If End With End If End If End Sub

Código Sub IB·AplicarEfecto() Dim r As Range, x As Range, c As Range, p As Range, b() As String, h As Long, s As Integer On Error Resume Next Set r = Application.InputBox("Selecciona el rango donde se aplicará el cambio de efecto:", "INGENIERÍA & BURÓTICA", , Type:=8) On Error GoTo 0 On Error Resume Next Set x = Application.InputBox("Selecciona el rango con las palabras a cambiar el efecto:", "INGENIERÍA & BURÓTICA", , Type:=8) On Error GoTo 0 s = InputBox("Seleccione el efecto deseado:" & vbCrLf & "2 para superíndice" & vbCrLf & "1 para subíndice", "INGENIERÍA & BURÓTICA", 1) If s <> 1 And s <> 2 Then MsgBox "efecto no válido. Use 1 para subíndice o 2 para superíndice." Exit Sub End If If Not r Is Nothing And Not x Is Nothing Then ReDim b(1 To x.Cells.Count) Dim i As Integer i = 1 For Each p In x b(i) = p.Value i = i + 1 Next p For Each c In r For i = LBoun...

Código Sub IB·CambiarTipoFuente() Dim r As Range, x As Range, c As Range, p As Range, b() As String, f As String On Error Resume Next Set r = Application.InputBox("Selecciona el rango donde se aplicará el cambio de tipo de fuente:", "INGENIERÍA & BURÓTICA", , Type:=8) On Error GoTo 0 On Error Resume Next Set x = Application.InputBox("Selecciona el rango con las palabras a cambiar el tipo de fuente:", "INGENIERÍA & BURÓTICA", , Type:=8) On Error GoTo 0 f = InputBox("Ingresa el tipo de fuente deseado:", "INGENIERÍA & BURÓTICA") If f <> "" Then If Not r Is Nothing And Not x Is Nothing Then ReDim b(1 To x.Cells.Count) Dim i As Integer i = 1 For Each p In x b(i) = p.Value i = i + 1 Next p For Each c In r For i = LBound(b) To UBound(b) If InStr(1, " " & c.Value & " ", " " & b(i) & " ") > 0 Then Dim posInicio As Integer posInicio = InStr(1, " ...

Código Sub IB·CambiarColorFuente() Dim r As Range, x As Range, c As Range, p As Range, b() As String, h As Long On Error Resume Next Set r = Application.InputBox("Selecciona el rango donde se aplicará el cambio de color de fuente:", "INGENIERÍA & BURÓTICA", , Type:=8) On Error GoTo 0 On Error Resume Next Set x = Application.InputBox("Selecciona el rango con las palabras a cambiar el color de fuente:", "INGENIERÍA & BURÓTICA", , Type:=8) On Error GoTo 0 h = RGB(255, 0, 0) Dim colorHex As String colorHex = InputBox("Ingresa el color de fuente deseado en formato hexadecimal:", "INGENIERÍA & BURÓTICA") If colorHex <> "" Then On Error Resume Next h = RGB( _ CLng("&H" & Mid(colorHex, 1, 2)), _ CLng("&H" & Mid(colorHex, 3, 2)), _ CLng("&H" & Mid(colorHex, 5, 2)) _ ) On Error GoTo 0 If h = 0 Then MsgBox "Formato de color no válido. Asegúrate de ingr...

Código para Rango Fijo Sub ValoresUnicos()     Dim L As Range, U As Range, i As Long, j As Long, dict As Object     Set L = Application.InputBox(Prompt:="Rango de datos:", Title:="IB", Type:=8)     Set U = Application.InputBox(Prompt:="Celda destino:", Title:="IB", Type:=8)     Set dict = CreateObject("Scripting.Dictionary")     For i = 1 To L.Rows.count         For j = 1 To L.Columns.count             If Not dict.Exists(L(i, j).Value) Then                 dict.Add L(i, j).Value, 0             End If         Next j     Next i     U.Resize(dict.count, 1).Value = Application.Transpose(dict.Keys) End Sub

Código para Rango Fijo Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, ) Is Nothing Then Dim o As Range, R As Range, B As Range, C As Range Dim celdaActiva As Range Set o = Range("") Set R = Range("") Set B = Range("") Set celdaActiva = ActiveCell Application.EnableEvents = False R.Value = o.Value For Each C In R C.Font.Bold = False For Each bCell In B If InStr(1, C.Text, bCell.Value) > 0 Then posInicial = InStr(1, C.Text, bCell.Value) longitud = Len(bCell.Value) C.Characters(posInicial, longitud).Font.Bold = True End If Next bCell Next C Application.EnableEvents = True If Not celdaActiva Is Nothing Then celdaActiva.Select End If End Sub Código para Rango Dinámico ...

Código Sub IB·QuitarTodosLosEspacios() Dim r As Range On Error Resume Next Set r = Application.InputBox("Selecciona el rango de celdas donde deseas quitar los espacios", "INGENIERÍA & BURÓTICA", Type:=8) On Error GoTo 0 If r Is Nothing Then Exit Sub End If For Each celda In r celda.Value = Replace(celda.Value, " ", "") Next celda MsgBox "Se han eliminado todos los espacios en el rango indicado.", , "INGENIERÍA & BURÓTICA" End Sub

Código Sub IB·QuitarEspaciosExcesivos() Dim r As Range On Error Resume Next Set r = Application.InputBox("Selecciona el rango de celdas donde deseas quitar los espacios excesivos", "INGENIERÍA & BURÓTICA", Type:=8) On Error GoTo 0 If r Is Nothing Then Exit Sub End If For Each celda In r celda.Value = Application.WorksheetFunction.Trim(celda.Value) Next celda MsgBox "Se han eliminado los espacios excesivos en el rango indicado.", , "INGENIERÍA & BURÓTICA" End Sub

En estos tiempos cambiantes, nuestra tierra se enfrenta a una crisis silenciosa pero devastadora: la contaminación en todas sus formas. Desde la opresiva niebla de smog que ciega nuestros cielos hasta la maraña de desechos plásticos que sofoca nuestros océanos, la huella de la actividad humana está dejando una marca innegable y peligrosa en el planeta. Nos encontramos en una encrucijada crítica. La contaminación del aire, del agua, del suelo, y otros recursos vitales para la vida es una realidad que no podemos seguir ignorando.  Cada bocanada de aire contaminado, cada vertido de productos químicos en nuestros ríos, cada desecho plástico que flota en el mar, son recordatorios alarmantes de esta crisis. La contaminación no reconoce fronteras ni distinciones; afecta a todas las formas de vida en nuestro planeta. Los impactos van más allá de lo estético; están minando la salud humana, alterando ecosistemas y amenazando la biodiversidad. La trágica pérdida de especies, la disminución de...

Código Function IB·RecuentoColorValor(Celda·con·Color·a·Contar As Range, Rango As Range, Optional ContarValor As Boolean = False) As Double Dim c As Range, R As Long R = 0 For Each c In Rango If c.Interior.Color = Celda·con·Color·a·Contar.Interior.Color Then If ContarValor Then If c.Value = Celda·con·Color·a·Contar.Value Then R = R + 1 End If Else R = R + 1 End If End If Next c IB·RecuentoColorValor = R End Function

Código Sub IB·CambiarTamañoFuente() Dim r As Range, x As Range, t As Integer, c As Range, p As Range Dim b() As String On Error Resume Next Set r = Application.InputBox("Selecciona el rango donde se aplicará el cambio de tamaño de fuente:", "INGENIERÍA & BURÓTICA", , Type:=8) On Error GoTo 0 On Error Resume Next Set x = Application.InputBox("Selecciona el rango con las palabras a cambiar el tamaño de fuente:", "INGENIERÍA & BURÓTICA", , Type:=8) On Error GoTo 0 t = InputBox("Ingresa el tamaño de fuente deseado:", "INGENIERÍA & BURÓTICA") If Not r Is Nothing And Not x Is Nothing And t > 0 Then ReDim b(1 To x.Cells.Count) Dim i As Integer i = 1 For Each p In x b(i) = p.Value i = i + 1 Next p For Each c In r For i = LBound(b) To UBound(b) If InStr(1, " " & c.Value & " ", " " & b(i) & " ") > 0 Then Dim posInicio As Integer posInicio = InStr(1, " " ...

Código Private Sub Worksheet_Change(ByVal Target As Range) Dim w As Worksheet, t As ListObject, c As ListColumn Set w = ThisWorkbook.Worksheets("") Set t = w.ListObjects("") Set c = t.ListColumns("") If Not Intersect(Target, c.DataBodyRange) Is Nothing Then With t.Sort .SortFields.Clear .SortFields.Add2 Key:=c.DataBodyRange, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With t.ShowAutoFilter = False End If End Sub