automatically unlock incoming sheet - import file macro

Option Explicit
Const PW As String = "trinity"
Dim lRw As Long
Sub ImportData()
    Dim oWb As Workbook

    Dim sFilter As String, sTitle As String, sFile As Variant
    On Error GoTo exit_proc:
    sFilter = "Excel Files (*.xl*),*.xl*"
    sTitle = "Please Select an Excel File"
    sFile = Application.GetOpenFilename(sFilter, , sTitle)

    If sFile = "False" Then
        MsgBox "No file selected", vbCritical, "Cancelled"
        Exit Sub
    End If

    If LCase(Mid(sFile, InStrRev(sFile, "."), 3)) <> ".xl" Then
        MsgBox "Excel File not selected", vbCritical, , "Excel require"
        Exit Sub
    End If

    Workbooks.Open Filename:=sFile
    Set oWb = ActiveWorkbook

    If ActiveSheet.ProtectContents Then ActiveSheet.Unprotect PW

    With ThisWorkbook.Sheets(1)
        lRw = .Cells(.Rows.Count, 3).End(xlUp).Row + 1
        .Cells(lRw, 3).Value = .Cells(lRw - 1, 3).Value + 1
        .Cells(lRw, 1).Value = "Q" & .Cells(lRw - 1, 3).Value + 1
        .Cells(lRw, 2).Value = Format(Date, "short date")
        oWb.Sheets(1).Cells(1, 1).CurrentRegion.Offset(1).Copy .Cells(lRw, 4)
    End With

    Select Case MsgBox("Would you like to email the report?", vbYesNo Or vbQuestion Or vbDefaultButton1, "Email Report")

    Case vbYes
        EmailIt
    Case vbNo

    End Select

exit_proc:
    ActiveSheet.Protect PW
    oWb.Close False

    Set oWb = Nothing
End Sub
Sub EmailIt()

    Dim AddxCell As Excel.Range
    Dim AttachFile As String
    Dim olApp As Object
    Dim olMail As Object
    Dim olNS As Object
    Dim OutlookWasNotRunning As Boolean
    Dim Rng As Excel.Range
    Dim LastEntry As Excel.Range

    ' Check if Outlook is already running
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")

    If Err.Number <> 0 Then
        Err.Clear
        OutlookWasNotRunning = True
        Set olApp = CreateObject("Outlook.Application")
    Else: Set olApp = GetObject("Outlook.Application")
    End If

    ' Logon to the Messaging Application Program Interface
    ' This is how Oulook communicates with its folders and items
    Set olNS = olApp.GetNamespace("MAPI")
    olNS.Logon


    Set olMail = olApp.CreateItem(0)        'olMailItem = 0

    With olMail
        .To = ThisWorkbook.Sheets(1).Cells(lRw, 6).Value
        .Subject = "Invoice Query Acknowledgement"

        .Body = "Member Name: " & ThisWorkbook.Sheets(1).Cells(lRw, 5).Value & vbNewLine & _
                "Supplier Name: " & ThisWorkbook.Sheets(1).Cells(lRw, 7).Value & vbNewLine & _
                "Value on Query: " & ThisWorkbook.Sheets(1).Cells(lRw, 16).Value & vbNewLine & _
                "Query Ref.: " & ThisWorkbook.Sheets(1).Cells(lRw, 1).Value & vbNewLine & _
                "Supplier Invoice No.: " & ThisWorkbook.Sheets(1).Cells(lRw, 15).Value & vbNewLine & _
                "Date THS HQ Logged Query: " & Format(ThisWorkbook.Sheets(1).Cells(lRw, 7).Value, "short date")
        '/// show message for checking
        '        .display
        '/// use next line to simply send without checking
        .Send
    End With

    MsgBox "Report sent"

    ' End session and quit
    olNS.Logoff
    If OutlookWasNotRunning = True Then olApp.Quit

    ' Free memory
    Set olApp = Nothing
    Set olMail = Nothing
    Set olNS = Nothing

End Sub

Sub test2()


    Dim original_wb As Workbook
    Dim new_wb As Workbook
    Dim row_count As Long, col_count As Long, I As Long, J As Long
    Dim attachname As String, emailaddress As String
    Dim findprevem
    Dim OutApp As Object, OutMail As Object

    Set original_wb = ActiveWorkbook    'Workbooks.Open("P:\Cindy Simmers\Query Log\Rob - Query Log Work\THS_Query_Log.xlsm") 'adjust file location

    row_count = original_wb.Sheets(1).UsedRange.Rows.Count
    col_count = original_wb.Sheets(1).UsedRange.Columns.Count

    For I = 2 To row_count Step 1

        attachname = "THS_Direct_Trading_Terms_Contact_Details.xlsx"
        emailaddress = original_wb.Sheets(1).Cells(I, "W").Value    'email address from column T
        If emailaddress <> "" Then
            findprevem = Application.Match(emailaddress, original_wb.Sheets(1).Range(original_wb.Sheets(1).Cells(1, "W"), original_wb.Sheets(1).Cells(I - 1, "W")), 0)
            If IsError(findprevem) Then
                Set new_wb = Workbooks.Add

                original_wb.Sheets(1).Range("A1:W1").Copy Destination:=new_wb.Sheets(1).Range("A1")
                For J = I To row_count
                    If original_wb.Sheets(1).Cells(I, "W").Value = original_wb.Sheets(1).Cells(J, "W").Value And _
                       original_wb.Sheets(1).Cells(J, "X").Value <> "RESOLVED" And _
                       original_wb.Sheets(1).Cells(J, "Y").Value <> "INTERNAL QUERY" Then
                        original_wb.Sheets(1).Range("A" & J & ":W" & J).Copy Destination:=new_wb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1)
                    End If
                Next J

                Application.DisplayAlerts = False
                new_wb.Sheets(1).UsedRange.EntireColumn.AutoFit
                new_wb.SaveAs Environ("temp") & "\" & attachname
                new_wb.Close SaveChanges:=False
                Set new_wb = Nothing
                Application.DisplayAlerts = True

                Set OutApp = CreateObject("Outlook.Application")
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .To = emailaddress
                    .CC = ""
                    .BCC = ""
                    .Subject = "This is the Subject line"    'adjust subjectline!
                    .Body = "Dear Supplier," & vbCrLf & vbCrLf & "Attached are the terms/details we hold on file for your current trading terms and contact details with THS direct. Please can you confirm these details are correct by placing a 1 in cell Z3." & vbCrLf & "If there are any differences please overwrite the current terms in red font." & vbCrLf & "Once confirmed please return the complete spreadsheet to rob.marr@thstools.co.uk" & vbCrLf & vbCrLf & "These terms will be incorporated into our THS Supplier Buying Agreement (SBA) which will subsequently be sent to yourselves to sign and return." & vbCrLf & vbCrLf & "Rob"
                    .Attachments.Add (Environ("temp") & "\" & attachname)
                    .Send
                    '.Save
                End With

                Set OutMail = Nothing
                Set OutApp = Nothing

                Kill Environ("temp") & "\" & attachname
            End If
        End If
    Next

End Sub

Select allOpen in new window