Posts by trunten

Sub transpose()
    Dim a, b, i&, j&, k&
    
    With ActiveSheet.Range("A1").CurrentRegion
        a = .Value
        ReDim b(1 To .Count, 1 To 1)
        .ClearContents
    End With
    k = 0
    For i = 1 To UBound(a)
        For j = 1 To UBound(a, 2)
            k = k + 1
            b(k, 1) = a(i, j)
        Next j
    Next i
    ActiveSheet.Range("A1").Resize(UBound(b)).Value = b
    Erase a
    Erase b
End Sub

Private Const CF_UNICODETEXT As Long = 13&
Private Const CF_TEXT As Long = 1&
Private Const GMEM_ZEROINIT = &H40
Private Const GMEM_MOVEABLE = &H2
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
 
#If Win64 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongLong) As Long
    Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongLong) As LongPtr
    Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongLong) As LongPtr
    Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongLong) As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function CountClipboardFormats Lib "user32" () As Long
    Private Declare PtrSafe Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As String) As LongPtr
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongLong) As LongLong
    Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
#Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
    Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function CountClipboardFormats Lib "user32" () As Long
    Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
#End If

Public Function ClipBoard_HasFormat(ByVal peCBFormat) As Boolean
    Dim lRet As Long
 
    If OpenClipboard(0&) > 0 Then
        lRet = EnumClipboardFormats(0)
        If lRet <> 0 Then
            Do
                If lRet = peCBFormat Then
                    ClipBoard_HasFormat = True
                    Exit Do
                End If
                lRet = EnumClipboardFormats(lRet)
            Loop While lRet <> 0
        End If
        CloseClipboard
    Else
        MsgBox "Cannot open clipboard", vbCritical
    End If
End Function

Public Function GetClipBoard() As String
#If Win64 Then
    Dim hData As LongPtr
    Dim lByteLen As LongPtr
    Dim lPointer As LongPtr
    Dim lSize As LongLong
#Else
    Dim hData As Long
    Dim lByteLen As Long
    Dim lPointer As Long
    Dim lSize As Long
#End If

    Dim lRet As Long
    Dim abData() As Byte
    Dim sText As String
 
    lRet = OpenClipboard(0&)
    If lRet > 0 Then
        hData = GetClipboardData(CF_TEXT)
        If hData <> 0 Then
            lByteLen = GlobalSize(hData)
            lSize = GlobalSize(hData)
            lPointer = GlobalLock(hData)
            If lSize > 0 Then
                ReDim abData(0 To CLng(lSize) - CLng(1)) As Byte
                CopyMemory abData(0), ByVal lPointer, lSize
                GlobalUnlock hData
                sText = StrConv(abData, vbUnicode)
            End If
        Else
            MsgBox "Cannot open clipboard", vbCritical
        End If
        CloseClipboard
    End If
 
    GetClipBoard = sText
End Function
 
Public Function SetClipboard(clipText As String) As Boolean
    #If Win64 Then
        Dim hGlobalMemory As LongLong
        Dim lpGlobalMemory As LongPtr
        Dim hClipMemory As LongLong
    #Else
        Dim hGlobalMemory As Long
        Dim lpGlobalMemory As Long
        Dim hClipMemory As Long
    #End If
    
    Dim fOK As Boolean
 
    fOK = True
    #If Win64 Then
        hGlobalMemory = GlobalAlloc(GHND, LenB(clipText) + 1)
    #Else
        hGlobalMemory = GlobalAlloc(GHND, Len(clipText) + 1)
    #End If
    If hGlobalMemory = 0 Then
        Exit Function
    End If
    lpGlobalMemory = GlobalLock(hGlobalMemory)
    lpGlobalMemory = lstrcpy(lpGlobalMemory, clipText)
    If GlobalUnlock(hGlobalMemory) <> 0 Then
        fOK = False
        GoTo clean_exit
    End If
    If OpenClipboard(0&) = 0 Then
        fOK = False
        Exit Function
    End If
    EmptyClipboard
    hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
 
clean_exit:
    CloseClipboard
    ClipBoard_SetData = fOK
End Function

Public Sub ClearClipboard()
    OpenClipboard 0&
    EmptyClipboard
    CloseClipboard
End Sub

Public Function IsEmpty() As Boolean
    OpenClipboard 0&
    IsEmpty = (CountClipboardFormats = 0)
    CloseClipboard
End Function

Public Function IsString() As Boolean
    OpenClipboard 0&
    IsString = (IsClipboardFormatAvailable(CF_UNICODETEXT)) Or (IsClipboardFormatAvailable(CF_TEXT))
    CloseClipboard
End Function

Private Sub Class_Terminate()
    CloseClipboard
End Sub

Option Explicit

Sub lastModifiedFileInFolder()
    Dim fldr$, fn$, lastModifiedFile$, dt As Date
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then fldr = .SelectedItems(1)
    End With
    If fldr <> "" Then
        fn = Dir(fldr & "\*.xls*")
        While fn <> ""
            If dt = 0 Or FileDateTime(fldr & "\" & fn) > dt Then
                dt = FileDateTime(fldr & "\" & fn)
                lastModifiedFile = fn
            End If
            fn = Dir
        Wend
    End If
    If lastModifiedFile <> "" Then
        If MsgBox("Open last modified file?:" & vbLf & vbLf & lastModifiedFile & vbLf & vbLf & "Modified: " & dt, 68) = vbYes Then
            Workbooks.Open fldr & "\" & lastModifiedFile
        End If
    End If
End Sub

Sub fixDate()
    Dim cl As Long, i As Long, a
    
    Application.ScreenUpdating = False
    On Error GoTo error_exit
    With Sheets("My Store").Range("D3", Sheets("My Store").Cells(Sheets("My Store").Cells.SpecialCells(xlCellTypeLastCell).Row, "V"))
        For cl = 1 To .Columns.Count Step 2
            If Application.Count(.Offset(cl - 1)) > 0 Then
                '.Columns(cl).NumberFormat = "dd-mmm-yy" '<--uncomment to enforce number format
                With .Offset(, cl - 1).Resize(, 1)
                    a = .Value
                    For i = 1 To UBound(a)
                        If IsDate(a(i, 1)) Then a(i, 1) = DateSerial(Year(a(i, 1)), Month(a(i, 1)), Day(a(i, 1)))
                    Next i
                    .Value = a
                End With
            End If
        Next cl
    End With
    On Error GoTo 0
    Application.ScreenUpdating = True
    MsgBox "Done", vbInformation
    Exit Sub
    
error_exit:
    Application.ScreenUpdating = True
    On Error GoTo 0
    Resume
End Sub