Palabras clave: fecha, laborable, dia.lab.intl
Autor: xavi

---

Necesidad
Obtener que día será una fecha dada una fecha inicial, un número de laborales, un tipo de semana laboral y la utilización de una tabla de festivos.

Es una emulación (con ligeros cambios) de la función DIA.LAB.INTL de Excel

Function DiaLabIntl(dtmFechaInicial As Date, intDiasProceso As Integer, Optional strTipoSemanaLaboral As String = "0000011", Optional blnAplicaFestivos As Boolean = True) As Date
    ' Función análoga a la de Excel utilizando el tipo de semana laboral como cadena y un boolean para aplicar laborables y festivos
    ' En caso de aplicar festivos será necesario indicar el nombre de la tabla y el campo de la tabla que contiene la fecha
   
    ' La cadena de strTipoSemanaLaboral se establece con 7 ceros y unos. El cero indica laborable y el uno festivo.
    ' Así, "0000011" indica el fin de semana de sábado-domingo. Esa técnica nos permite gestionar (casi) cualquier combinación
   
   
    Const cTablaFestivos As String = "tblDatFestivos"
    Const cCampoFecha As String = "FechaFestiva"
   
    Dim dtmLaFecha  As Date
    Dim intdias As Integer
   
    ' Establecemos la fecha inicial
    dtmLaFecha = dtmFechaInicial
   
    ' Bucle sin condiciones
    Do
        ' Evaluamos si el día de la semana se ha estipulado como festivo.
        If Mid(strTipoSemanaLaboral, Weekday(dtmLaFecha, vbMonday), 1) = "1" Then
            ' Es un NO-laborable: no hacemos nada
        Else
            ' En este punto "parece" un laborable pero miramos si es festivo (si procede)
            If blnAplicaFestivos And DCount("*", cTablaFestivos, cCampoFecha & "= " & CLng(dtmLaFecha)) > 0 Then
                ' es un festivo: nada
            Else
                ' Ni es fin de semana, ni es festivo (sea porque no aplica, sea porque no lo es)
                intdias = intdias + 1
            End If
        End If
       
        ' Comprobamos si hemos alcanzado el limite de días
        If intdias >= intDiasProceso Then
            DiaLabIntl = dtmLaFecha
            Exit Function
        End If
        ' Aumentamos un día
        dtmLaFecha = DateAdd("d", 1, dtmLaFecha)
        ' Comprobación de seguridad
        If dtmLaFecha > DateAdd("d", intDiasProceso + 1000, dtmFechaInicial) Then
            MsgBox "Creo que nos hemos pasado de largo", vbExclamation
            DiaLabIntl = "01/01/1900"
            Exit Function
        End If
    Loop

End Function



Palabras clave: Excel, rango, copia, outlook, correo
Autor: Ron De Bruin
Extraído de: Ron De Bruin

La necesidad surge de pegar el contenido de un rango de un fichero Excel abierto como parte del cuerpo de un correo electrónico.

Después de muchas vueltas y pruebas este código de Ron De Bruin soluciona el problema

Requiere una copia previa del rango o pasarle la dirección para que lo haga la función.



Function rngHTML(Rng As Object) ' Range
    Dim fso         As Object
    Dim ts          As Object
    Dim TempWB      As Object    ' Workbook
    Dim TempFile    As String
   
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
   
    '' copy the range and create a new workbook to paste the data into
    'Rng.Copy
   
   
    Set TempWB = xlsApp.Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        .Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    '' publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
             SourceType:=xlSourceRange, _
             fileName:=TempFile, _
             Sheet:=TempWB.Sheets(1).Name, _
            Source:=TempWB.Sheets(1).UsedRange.Address, _
            HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    '' read all data from the htm file into rngHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    rngHTML = ts.readall
    ts.Close
    rngHTML = Replace(rngHTML, "align=center x:publishsource=", "align=left x:publishsource=")

    TempWB.Close savechanges:=False
    '' delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function


Palabras clave: color, paleta, API, CHOOSECOLOR
Autor: ni me acuerdo
Extraído de: No sabria decir

Objetivo:
Abrir la paleta de colores para realizar una selección

En un módulo independiente:

Option Compare Database
Option Explicit

' Declaraciones (para aDialogColor)
#If Win64 Then
    Private Declare PtrSafe Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As COLORSTRUC) As Long
#Else
    Private Declare Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As COLORSTRUC) As Long
#End If

' Estructura (para aDialogColor)
Private Type COLORSTRUC
  lStructSize       As Long
  hWnd              As Long
  hInstance         As Long
  rgbResult         As Long
  lpCustColors      As String
  Flags             As Long
  lCustData         As Long
  lpfnHook          As Long
  lpTemplateName    As String
End Type

' Estructura de devolución de valor
Public Type udtSysDialogColor
    IsSelected      As Boolean
    PreSelected     As Variant
    SelectedColor   As Long
End Type
Public uSysDialogColor  As udtSysDialogColor

' Constantes (para aDialogColor)
Private Const CC_SOLIDCOLOR = &H80
Private Const CC_RGBINIT = &H1

Public Function aDialogColor()
   
    Dim x As Long, CS As COLORSTRUC, CustColor(16) As Long
   
    CS.lStructSize = Len(CS)
   
    CS.hWnd = Application.hWndAccessApp
   
    CS.Flags = CC_SOLIDCOLOR Or CC_RGBINIT
    CS.lpCustColors = String$(16 * 4, 0)
   
    ' Were we passed a value in PreselectedColor
    If Not IsMissing(uSysDialogColor.PreSelected) Then
        CS.rgbResult = uSysDialogColor.PreSelected
    End If
   
    x = CHOOSECOLOR(CS)
    If x = 0 Then
        ' ERROR - return preselected Color
        uSysDialogColor.IsSelected = False
        Exit Function
    Else
        ' Normal processing
        uSysDialogColor.SelectedColor = CS.rgbResult
        uSysDialogColor.IsSelected = True
    End If
 
End Function


Palabras clave: configuración, resolución, TWIPS, API, GetSystemMetrics
Autor: Jacob Hilderbrand
Extraído de: VBA Express

Objetivo:
Determinar la resolución de la pantalla y proponer cambio.

En un módulo independiente:

Option Explicit

Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Const SM_CXSCREEN = 0
Const SM_CYSCREEN = 1

Sub VerifyScreenResolution(Optional Dummy As Integer)
     
    Dim x  As Long
    Dim y  As Long
    Dim MyMessage As String
    Dim MyResponse As VbMsgBoxResult
     
    x = GetSystemMetrics(SM_CXSCREEN)
    y = GetSystemMetrics(SM_CYSCREEN)
    If x = 1024 And y = 768 Then
    Else
        MyMessage = "Your current screen resolution is " & x & " X " & y & vbCrLf & "This program " & _
        "was designed to run with a screen resolution of 1024 X 768 and may not function properly " & _
        "with your current settings." & vbCrLf & "Would you like to change your screen resolution?"
        MyResponse = MsgBox(MyMessage, vbExclamation + vbYesNo, "Screen Resolution")
    End If
    If MyResponse = vbYes Then
        Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,3")
    End If
End Sub


Palabras clave: Excel, hoja, nombre, formula
Autor: Argenis
Extraído de: Grupo de Whatsapp PowerBI Barcelona


Jordi Bosch, en el grupo de WhatsApp de PowerBI Barcelona lanza esta pregunta:

¿Por casualidad, alguno sabe cómo aplicar una fórmula en Excel para obtener el nombre de la pestaña en la misma pestaña sin referencias circulares ni VBA? Gracias 

Respuesta de Argenis

=EXTRAE(CELDA("nombrearchivo");ENCONTRAR("]";CELDA("nombrearchivo"))+1;31)

No hace falta decir nada más.

Palabras clave: configuración, regional, API, SetLocaleInfo
Autor: Cecilia Colalongo
Extraído de: La Web del programador

Objetivo:
Cambiar la configuración regional de la máquina. En este ejemplo, el formato de fecha y los separadores decimales y de miles.

En un módulo independiente:

Option Compare Database
Option Explicit

#If Win64 Then
    Public Declare PtrSafe Function GetSystemDefaultLCID Lib "kernel32" () As Long
    Public Declare PtrSafe Function SetLocaleInfo Lib "kernel32" Alias "SetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String) As Long
#Else
    Public Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long
    Public Declare Function SetLocaleInfo Lib "kernel32" Alias "SetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String) As Long
#End If
Public Const LOCALE_SSHORTDATE = &H1F
Public Const LOCALE_SDECIMAL = &HE
Public Const LOCALE_STHOUSAND = &HF

Function testCambioConfReg()
    SetLocaleInfo GetSystemDefaultLCID, LOCALE_SSHORTDATE, "dd/MM/yyyy"
    SetLocaleInfo GetSystemDefaultLCID, LOCALE_SDECIMAL, "."
    SetLocaleInfo GetSystemDefaultLCID, LOCALE_STHOUSAND, ","
End Function


Palabras clave: array vacío
Autor: Rubén Vigón

Objetivo
Saber si un Array tiene elementos o no.
En ocasiones tenemos un array no inicializado (o borrado su contenido con Erase) y queremos evaluar ese estado. Rubén Vigón nos ofreció esta respuesta allá por el 2005



Dim matriz() As Variant
If Not Not matriz Then
  Debug.Print "Inicializada"
Else
  Debug.Print "No inicializada"
End If

Palabras clave: contar, lineas, fichero, texto
Autor: no lo recuerdo

Objetivo
Obtener la cantidad de líneas que contiene un fichero de texto


Function DameLineasFichero(ByVal strRuta As String) As Long
    Dim f As Integer
    Dim strTexto As String
    Dim arrLineas() As String
   
    f = FreeFile
    Open strRuta For Input As #f
    strTexto = Input(LOF(f), #f)
    Close #f
    arrLineas = Split(strTexto, vbNewLine)
    DameLineasFichero = UBound(arrLineas) - LBound(arrLineas) + 1
    Erase arrLineas
End Function


Palabras clave: Cadena, repetir, contar
Autor: David M.M. y Eva Etxebeste

Objetivo
Rafa pregunta:

Citar¿Recordáis si hay alguna función de VBA que me cuente las coincidencias de un carácter en una cadena de texto?

"Hola grupito". Si busco la o que me retorne 2.

Responde Mihura
Mira... una del ternero


Function RT_NumRepeticionesCaracter(ByVal Cadena As Variant, ByVal Caracter As Variant) As Long   'V0
' El valor que devolverá la función será el número de partes en que la función Split ha separado
' la cadena original con el caracter introducido menos uno. Primera función de David M.M.
    Dim Matriz_Split() As String
    RT_NumRepeticionesCaracter = 0
    If Nz(Cadena, "") = "" Then Exit Function
    Matriz_Split() = Split(Cadena, Nz(Caracter, ""))
    RT_NumRepeticionesCaracter = UBound(Matriz_Split)
End Function


A lo que Eva Etxebeste replica...
En una línea


Len(cadena) - Len(Replace(cadena, charBusqueda, ""))


Palabras clave: convertir, fecha, formato
Autor: xavi

---

Necesidad
Convertir en fecha una cadena de texto que puede venir en distintos formatos (ddmmyy o yyyymmdd, por ejemplo)


Function fntConvierteFecha(strFecha As String, strFormato As String) As Date

    Dim iniAño                      As Integer
    Dim iniMes                      As Integer
    Dim iniDia                      As Integer
   
    Dim lenAño                      As Integer
    Const lenMes                    As Integer = 2
    Const lenDia                    As Integer = 2
   
    ' Función que toma cualquier formato que se pase como argumento para devolver una gfecha
    ' El separador no tiene porqué coincidir con elde la fecha; bastará con cualquier caracter, incluso un espacio.
   ' Ejemplo:  fntConvierteFecha("22-25-12", "yy dd mm") devuelve el dia de navidad del 2022
   
    ' Solo podemos admitir formatos que contengan "dd", "mm" y "yy" (por lo menos 2 'y')
    ' Empezamos por "dd"
    If InStr(1, strFormato, "dd") = 0 Then
        MsgBox "El formato pasado como argumento no es admisible.", vbExclamation, "Error"
        fntConvierteFecha = Empty
        Exit Function
    End If
    ' Seguimos por "mm"
    If InStr(1, strFormato, "mm") = 0 Then
        MsgBox "El formato pasado como argumento no es admisible.", vbExclamation, "Error"
        fntConvierteFecha = Empty
        Exit Function
    End If
    ' Acabamos por "yy"
    ' venga como yy o como yyyy, por lo menos yy debe existir
    If InStr(1, strFormato, "yy") = 0 Then
        MsgBox "El formato pasado como argumento no es admisible.", vbExclamation, "Error"
        fntConvierteFecha = Empty
        Exit Function
    End If
   
   ' En este punto ya podemos tratar cualquier cosa
    iniAño = InStr(1, strFormato, "y")
    iniMes = InStr(1, strFormato, "m")
    iniDia = InStr(1, strFormato, "d")
   
    lenAño = IIf(InStr(1, strFormato, "yyyy") > 0, 4, 2)
   
    fntConvierteFecha = DateSerial(Mid(strFecha, iniAño, lenAño), Mid(strFecha, iniMes, lenMes), Mid(strFecha, iniDia, lenDia))

End Function