Posts by dangelor

Sub test()
    Dim vFiles As Variant, v As Variant
    Dim wb As Workbook, ws As Worksheet, sTabName As String
    Const sPATH As String = "C:\temp"             'change as needed

    vFiles = fnGetFiles(sPATH, "txt")
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    With ThisWorkbook
        For Each v In vFiles
            Set wb = Workbooks.Open(v, ReadOnly:=True)
            sTabName = wb.Worksheets(1).Name
            ThisWorkbook.Activate
            If Evaluate("ISREF('" & sTabName & "'!A1)") Then .Worksheets(sTabName).Delete
            wb.Worksheets(1).Copy after:=.Sheets(.Sheets.Count)
            wb.Close
        Next v
    End With
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    
End Sub
Private Function fnGetFiles(sPATH As String, Optional EXT As String) As Variant
    Dim sFileName As String
    With CreateObject("Scripting.Dictionary")
        If EXT = vbNullString Then
            sFileName = Dir(sPATH, vbNormal)
        Else
            sFileName = Dir(sPATH & "\*." & EXT & "*", vbNormal)
        End If
        Do While Not sFileName = vbNullString
            .Item(sPATH & "\" & sFileName) = Empty
            sFileName = Dir
        Loop
        fnGetFiles = .keys
    End With
End Function

Sub ZipTest()
    Dim vFileName As Variant
    Dim objShell As Object, vPath As Variant
    
    vFileName = "C:\Temp\Test.zip" 'Name of zip file to create
    vPath = "C:\Temp\Files2Zip\" 'Folder holding the files to zip
    
    Open vFileName For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
    
    'Code to transfer selected files to vPath
    
    Set objShell = CreateObject("Shell.Application")
    objShell.Namespace(vFileName).CopyHere objShell.Namespace(vPath).items
    Set objShell = Nothing
End Sub

Sub Wait15()
    Dim i As Long
    For i = 0 To 3
        If wBook.ReadOnly = True Then
            If i = 3 Then
                MsgBox "Database is in use. Please try again after some time.", vbOKOnly + vbCritical, "Error"
                Exit Sub
            End If
            Application.Wait Now + TimeValue("0:00:05")
        End If
    Next i
End Sub

Option Explicit

Sub Test_on_File_Copies()
    '!!! WARNING !!!
    'This code will delete worksheets.
    '---------------------------------------
    
    Dim sGivenFolderPath As String, sExt As String
    Dim vFiles As Variant, vName As Variant
    Dim wb As Workbook, ws As Worksheet

    sGivenFolderPath = "C:\Temp"                  'change path and extension as needed
    sExt = "xlsx"
    vFiles = GetFiles(sGivenFolderPath, sExt)
    
    If UBound(vFiles) = -1 Then
        MsgBox " No files found."
        Exit Sub
    End If
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    For Each vName In vFiles
        Set wb = Workbooks.Open(sGivenFolderPath & "\" & vName)
        For Each ws In wb.Worksheets
            Select Case ws.Name
                Case "Sheet1", "Sheet2"           'Worksheets to be deleted
                    ws.Delete
            End Select
        Next ws
        wb.Close SaveChanges:=True
    Next vName
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

Function GetFiles(sPath As String, Optional Ext As String) As Variant
    Dim sFileName As String
    With CreateObject("Scripting.Dictionary")
        If Len(Ext) = 0 Then
            Ext = "\*.*"
        Else
            Ext = "\*." & Ext
        End If
        sFileName = Dir(sPath & Ext, vbNormal)
        Do While Not sFileName = vbNullString
            .Item(sFileName) = Empty
            sFileName = Dir
        Loop
        GetFiles = .Keys
    End With
End Function

Sub test()
    Dim rg As Range, v As Variant, i As Long
    
    'Assumptions:
        'one column of data in column 1
        'each line of data ends with long alpha-numeric part
        'long alpha-numeric part is duplicated in each line of data
        
    'Writes truncated data in column 2
    
    Set rg = Cells(1, 1).CurrentRegion.Columns(1)
    For i = 1 To rg.Rows.Count
        v = Split(rg.Cells(i, 1), " ")
        v = v(UBound(v))
        rg.Cells(i, 1).Offset(, 1) = Left(rg.Cells(i, 1), InStr(1, rg.Cells(i, 1), v) + Len(v))
    Next i
    
End Sub

Option Explicit

Sub Email_Test()
    Dim rg As Range, c As Range, sBCC As String

    Set rg = Worksheets("Sheet1").Cells.Find("WorkAnniversaryDueDate")
    Set rg = Intersect(rg.CurrentRegion, Columns(rg.Column))
    
    For Each c In rg
        If c.Value = Date Then sBCC = sBCC & c.Offset(, -2).Value & ";"
    Next c
    
    If sBCC = vbNullString Then
        MsgBox "No receipients found"
    Else
        With CreateObject("Outlook.Application").CreateItem(0)
            .Display
            .BCC = sBCC
            .Subject = "Report"
        End With
    End If
End Sub

Sub DeleteMyRows2()
    Dim ws As Worksheet
    Set ws = Worksheets("DataBase")
    
    Dim student As String
    student = Worksheets("Summary").Cells(7, 8)
    
    With ws.Cells(1, 3).CurrentRegion
        .AutoFilter 3, student
        .SpecialCells(xlCellTypeVisible).EntireRow.Delete
        .AutoFilter
    End With
End Sub

Private Sub CommandButton2_Click()
    Dim ws As Worksheet, lastrow As Long
    Dim v As Variant

    Worksheets("SheetJS").Range("C43:C543").Copy
    Set ws = Workbooks.Open(Filename:=Environ("userprofile") & "\Desktop\output.xlsx").Sheets("Main")
    With ws
        lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
        .Cells(lastrow + 1, 1).PasteSpecial xlPasteValues
        lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
        .Range("A1:A" & lastrow) = .Range("A1:A" & lastrow).Value2
        .Range("A1:A" & lastrow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
End Sub

Option Explicit
Private Sub CommandButton2_Click()
    Dim ws As Worksheet, lastrow As Long

    Worksheets("SheetJS").Range("C43:C543").Copy
    Set ws = Workbooks.Open(Filename:="blahblah\output.xlsx").Sheets("Main")
    With ws
        lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
        .Cells(lastrow + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
        lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
        .Range("A1:A" & lastrow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
End Sub

Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim f As Object, sPath As String, sFileName As String
    If SaveAsUI = False Then
        Cancel = True
        sFileName = Worksheets("PR Form").Range("W2").Value2 & ".xlsm"
        Set f = Application.FileDialog(msoFileDialogFolderPicker)
        With f
            .InitialFileName = "C:"
            If .Show = True Then
                sPath = .SelectedItems(1)
            End If
        End With
        If sPath <> vbNullString Then
            Application.EnableEvents = False
            ActiveWorkbook.SaveAs Filename:=sPath & Application.PathSeparator & sFileName, FileFormat:=52
            Application.EnableEvents = True
        Else
            MsgBox "Action cancelled.", vbInformation + vbOKOnly, "No Path Selected"
            Cancel = True
        End If
    End If
End Sub

    Dim OUTAPP As Object
    Dim sFileName As String, i As Long, msg As Long

    Call ws_settings
    Set OUTAPP = CreateObject("OUTLOOK.APPLICATION")
    For i = 3 To ws6.Cells(Rows.Count, 1).End(xlUp).Row
        msg = 0
        If ws6.Cells(i, 11) <> "" Then
            sFileName = ws6.Cells(i, 12)
            If sFileName = "" Then
                msg = MsgBox("There was no attachment file listed for the email to " _
                    & ws6.Cells(i, 11) & "." & vbCrLf & "Do you wish to continue?", _
                      vbQuestion + vbYesNo, "No Attachment Specified")
                If msg = vbNo Then GoTo nexti
            End If
            If Dir(sFileName, vbNormal) = "" Then
                msg = MsgBox("The attachment file listed for the email to " _
                    & ws6.Cells(i, 11) & "does not exist." & vbCrLf & "Do you wish to continue?", _
                      vbQuestion + vbYesNo, "Attachment Missing")
                If msg = vbNo Then GoTo nexti
            End If
            With OUTAPP.createitem(0)
                .To = ws6.Cells(i, 11).Value
                .Subject = "Insurance Policy Renewal Reminder"
                .body = ws6.Cells(i, 15).Value
                If msg = 0 Then .attachments.Add sFileName
                .Save
            End With
        End If
nexti:
    Next i
    Set OUTAPP = Nothing

Sub SearchDB()
    Dim v As Variant, n As Variant
    Dim i As Long, j As Long

    With ThisWorkbook
        v = .Worksheets("Database").UsedRange.Resize(, 9)
        n = .Worksheets("New").UsedRange
        
        For i = LBound(v) To UBound(v)
            For j = LBound(n) To UBound(n)
                If v(i, 2) = n(j, 2) Then 'first name
                    If v(i, 3) = n(j, 3) Then 'last name
                        If v(i, 7) = n(j, 7) Then 'mobile
                            If v(i, 8) = n(j, 8) Then 'email
                                'puts the matching new serial number to col I of the database
                                v(i, 9) = n(j, 1)
                            End If
                        End If
                    End If
                End If
            Next j
        Next i
        
        .Worksheets("Database").UsedRange.Resize(, 9) = v
                
    End With
End Sub