automatically unlock incoming sheet - import file macro

The "import" button on the attached sheet entitled "master query log"  is designed to automatically add the details of the chosen file sheet to the bottom row of the master query log spreadsheet. However in the future the files that need to be imported will be password protected (current sheet).

Two queries.

1.Could someone change the coding of the macro assigned to the "import" button so it will import the same information as it is currently set up to but for the attached sheet "random query". I have attached an example of the previous import file (query) for you to test and see how it should work for the "random query" template instead.

Note: import files will always be in the layout and format of that found in the attached "random query" sheet. They will always be current sheet protected with the password trinity.

2. Automatically unlock the incoming sheet so it can be copied into the master query log. The password is trinity
Master-Query-Log-V01--2-.xlsm
random-query.xlsm
query1.xlsx
mikes6058Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Roy CoxGroup Finance ManagerCommented:
I'll add some code to my original one to test for protection and unprotect the sheet if necessary. Do you want protection addin back when finished?
0
mikes6058Author Commented:
Yes please, will the code work for the new "random query" sheet? presumably you will have to make some adjustments as the layout is slightly different to the "query1" file.

Thanks
0
Roy CoxGroup Finance ManagerCommented:
Hi Mike the Random Query sheet has it's VBA protected but the actual code in it is mostly recorded. Is that code yours?

I've added code for the protection . Are you importing to the same log workbook? I see the headings are not matching so we have the situation that we originally had. I believe you amended the order on the template.

The other question about emailing and my suggestion of filtering needs looking at after we have completed this one simply because we need to combine the codes so that it works together.
0
Cloud Class® Course: Microsoft Windows 7 Basic

This introductory course to Windows 7 environment will teach you about working with the Windows operating system. You will learn about basic functions including start menu; the desktop; managing files, folders, and libraries.

Roy CoxGroup Finance ManagerCommented:
Actually I don't think it does need  changing. See attached.
Master-Query-Log-V01--2-.xlsm
0
mikes6058Author Commented:
I am getting the attached error when I click import
macro-error.docx
0
Roy CoxGroup Finance ManagerCommented:
I must have deleted a line by mistake. Replace the code with this

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

Open in new window

0
mikes6058Author Commented:
The macro is copying the wrong data.

It should be copying the information from the "random query" sheet and pasting it under the corresponding column headings in the query log as it did before.

I have attached a copy of the result after importing the "random query" sheet. You will see it has copied row two rather than the query info.

I have also attached a sheet containing the info from the "random query" sheet that the macro should have copied and pasted.
desired-info-to-be-copied.xlsx
wrong-result.xlsm
0
Roy CoxGroup Finance ManagerCommented:
The data is on a different row, I was checking the headers. Will you be able to change the start row in the other query to match this workbook?
wrong-result.xlsm
0
mikes6058Author Commented:
That's great thanks I will only ever be importing from sheets with the same layout to the random query sheet.

The Only issue now is that columns J,L,M are rerturning #N/A instead if the values on the random query sheet?
0
mikes6058Author Commented:
Also could you make it so that when the info is pasted all the visual source formatting is removed e.g. coloured cells, forts, bold etc.
0
Roy CoxGroup Finance ManagerCommented:
Hi Mike

here's the updated import code. Copy it over the old one
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(11, 1).CurrentRegion.Offset(1).ClearFormats
               oWb.Sheets(1).Cells(11, 1).CurrentRegion.Offset(1).Copy
        oWb.Sheets(1).Cells(11, 1).CurrentRegion.Offset(1).PasteSpecial xlValues
        oWb.Sheets(1).Cells(11, 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

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
mikes6058Author Commented:
That's spot on.

I've a few more queries relating to this project.

See link below for what I imagine is a fairly quick query.

http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28657905.html
0
Roy CoxGroup Finance ManagerCommented:
I'll have a look. I still need to do the other email report. I have almost finished it.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.