Solved: prevent errors with multiple user input simultaniously.

[gringo287]

Hi guys,

Ive taken over a project from someone else and although it works fine, it requires more work/time to update and maintain, than i have and as excel is capable of doing this work for me, it would a waste not to.

In a nut shell, its a way for users to record certain data and update this on the database (managers version, that tracks trends and such). the problem is that that, all this means is that the data gets sent to me via email (with excel attachment), for me to then manually update to the master sheet.

Im testing out using the macro im sure you're all aware of, that opens the master sheet to perform the update and then close the master sheet again.

This works fine, but i have a few questions.

1/ A few of the people ive asked to test it, are being asked to save the master copy, before it can proceed to perform the update??. Around 10 people have tested and this only happens for two people.

2/ There is a potential for multiple people to "press the button" at the same time, which will casue issues. it seems to work Fine when two people use it simultaniously, but it doesnt like three at once. The error was along the lines of it being in use and to try again later.

Its not absolutely imperative that 100% of the users entries are completed, so it wouldnt be the end of the world, if, when this happens, excel just ignores the later of the entry attempts and moves on without error.

Any ideas

[BrianMH]

Multiuser spreadsheets are something I absolutely hate. They have issues that you mention and they often corrupt meaning that the whole spreadsheet is lost (pray you have a backup). My suggestion would be to change it to an actual access database and run reporting off of this. It is a lot of work at first but is certainly worth it when it comes to not maintaining it and fixing issues.

If you can't do that maybe keep it so people email you and run a batch to update it onto the main spreadsheet every so often so it only takes a few minutes of your time.

[gringo287]

Bugger, I had my fingers crossed that this wouldn't be the response. There will realistically only be a small chance of simultaneous entry attempts, as there are only around 10 user's that would potentially be needing to use it and even then they're only using it for around 30 second at a time to input the data. Is there no way to set a macro to queue the procedure until the master copy is closed?.

[gringo287]

ok, so my stubborness has subsided, as the potential complications with my initial intention are too many.

BrianMH, sorry for not just taking you advice straight away. Please could you (our any other kind soul) elaborate on

If you can't do that maybe keep it so people email you and run a batch to update it onto the main spreadsheet every so often so it only takes a few minutes of your time.

[BrianMH]

Well pretty simple. You say people are emailing you already. My suggestion would be to set up a outlook rule to have them move to a folder and then once a day download them all and then use a script to open them, get the information off of them and update your main spreadsheet. I've got a script to download all attachments from all mails in an outlook folder. It is at work but I can give it to you tomorrow. Once you have the files it is a pretty simple thing extract the information and update your spreadsheet through VBA. How you do this exactly depends on your structure.

[gringo287]

The current set up does send an email to me with an attachment containing the weeks records from each advisor. Ive set up a rule so that they all go to a dedicated folder. Its just too laborious, opening each individual email and then copying/pasting into the master sheet. I'd be very grateful for any assistance you can provide.

[BrianMH]

Post a copy of the source sheet and where it is going. If you make any modifications before pasting it outline those. I'm actually not back at work until Monday and I don't have office at home so if you can wait until then that would help.

If I haven't replied by mid Monday shoot me a PM to remind me. Should be pretty simple to sort out for you. It is pretty much what your talking about that started me on writing VBA.

[gringo287]

Its not going wrong as such.

The current set up works, it just requires too much manual input.

My adjustment also works, providing only one person is updating it at the same time.

the current set up below, is what sends the attachment to me.

[VBA]Option Explicit


Sub EmailWithOutlook()
If MsgBox("This will now close your week, and this file can not be used! Lee will send you a new file on Monday Morning. Are you sure?", vbYesNo) = vbNo Then Exit Sub
'Variable declaration
Dim oApp As Object, _
oMail As Object, _
WB As Workbook, _
FileName As String

'Turn off screen updating
Application.ScreenUpdating = False

'Make a copy of the active sheet and save it to
'a temporary file
ActiveWorkbook.Sheets("PartsData").Copy
Set WB = ActiveWorkbook
FileName = "Temp.xlsx"
On Error Resume Next
Kill "K:\" & FileName
On Error GoTo 0
WB.SaveAs FileName:="K:\" & FileName

'Create and show the outlook mail item
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
With oMail
'Uncomment the line below to hard code a recipient
'.To = "someone@somedomain.com"
'Uncomment the line below to hard code a subject
'.Subject = "Look at my workbook!"
.Attachments.Add WB.FullName
.To = ""
.Subject = ""
.Send
End With

'Delete the temporary file
WB.ChangeFileAccess Mode:=xlReadOnly
Kill WB.FullName
WB.Close savechanges:=False

'Restore screen updating and release Outlook
Application.ScreenUpdating = True
Set oMail = Nothing
Set oApp = Nothing
Sheets("Final").Select
End Sub[/VBA]

[BrianMH]

If you can post a copy of the source workbook and the workbook you want it merging into that would be helpful. You can remove any personal data it just needs to hold the structure.

Here is something to help the downloading of the mails.

Assign this bit to a command button (rename the sub as necessary).

[VBA]
Private Sub Download_folder_Click()
MsgBox ("Open Outlook and select the folder you want to download from" & vbNewLine & "Please be aware this downloads the entire folder")
strSavePath = svpth
If strSavePath = "" Then
MsgBox "No folder was selected"
Exit Sub
End If
DownloadFolder (strSavePath)
End Sub
[/VBA]

Then add these subs to a module.

[VBA]
Option Explicit
Public AttachmentCount As Integer

Function DownloadFolder(strPath As String)
'function to download every attachment in the selected outlook folder (selected in outlook application).

Dim olApp As Outlook.Application
Dim expl As Outlook.Explorer
Dim currentItems As Outlook.Items
Dim itemsWithAttachments As Outlook.Items
Dim myItem As Object
Dim itemcount As Integer
Dim msg

Set olApp = Outlook.Application
Set expl = olApp.ActiveExplorer
Set currentItems = expl.CurrentFolder.Items
itemcount = currentItems.Count

AttachmentCount = 0

For Each myItem In currentItems
If TypeName(myItem) = "MailItem" Or TypeName(myItem) = "DocumentItem" Then
Set msg = myItem
Call downloadmail(msg, strPath)
End If
Next
MsgBox ("downloaded " & AttachmentCount & " attachments from " & itemcount & " emails")
End Function

Sub downloadmail(myMailItem, strPath As String)
Dim strFileName As String
Dim strNewName As String
Dim strPre As String
Dim strExt As String
Dim myolAttachments As Attachments
Dim myolAtt As Attachment
Dim intExtlen As Integer
Dim w As Integer
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
If myMailItem.Attachments.Count <> 0 Then
Set myolAttachments = myMailItem.Attachments
For Each myolAtt In myolAttachments
strFileName = myolAtt.DisplayName
'find out if the file exists in the download location already and if so rename
'to a filename including a number eg. file(1).xls
If fs.fileexists(strPath & "\" & strFileName) = True Then
strNewName = strFileName
'get the length of the extension including the .
intExtlen = Len(strFileName) - InStrRev(strFileName, ".") + 1
'check there is actually a file extension and if not set extension to blank
'and set strPre to the full file name
If InStrRev(strFileName, ".") > 0 Then
strExt = Right(strFileName, intExtlen)
strPre = Left(strFileName, Len(strFileName) - intExtlen)
Else
strExt = ""
strPre = strFileName
End If
'increase the file number (w) until the file name no longer exists file(1).ext to file(2).ext etc
'strpre = filename before extension strext = extension w=file number
While fs.fileexists(strPath & "\" & strNewName) = True
w = w + 1
strNewName = strPre & Chr(40) & w & Chr(41) & strExt
Wend
'set the new filename
strFileName = strNewName
w = 0
End If
myolAtt.SaveAsFile strPath & "\" & strFileName
AttachmentCount = AttachmentCount + 1
Set myolAtt = Nothing
Next
End If
myMailItem.UnRead = False
End Sub

Function svpth() As String
'this returns a string for a folder path the user selects
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
Dim strSelectedItem As String
With fd

.Title = "please choose save path"

If .Show = -1 Then
svpth = .SelectedItems.Item(1)
Else
End If
End With
End Function
[/VBA]

This will download all the attachments on all the mails in the folder you highlight in outlook. You may want to create a completed folder to move them into once you are done to avoid duplication. I also have one that downloads just the highlighted mails in a folder instead of an entire folder if you like.

Post those other bits and I will sort out something to automatically put all the users data onto a main workbook.

[gringo287]

thats excellant thank you. it'll probably be later today or this evening before im able to look at this properly, so ill get the info sent to you asap

[gringo287]

Hi Brian,

I'm sure i'm being stupid, but, its only letting me attach one file. I'll work it out and send the other one in a minute

[gringo287]

there we go

[BrianMH]

add this code to a macro workbook. You will need to choose your destination workbook and then select the source workbooks.


[VBA]Option Explicit
Sub combineworkbooks()
Dim wbSource As Workbook
Dim wbDest As Workbook
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim sDestPath As String
Dim vDestFile
Dim vSourceFiles
Dim rBottom As Range
Dim rCopy As Range
Dim iCol As Long
Dim iWb As Integer
vDestFile = Application.GetOpenFilename("Excel Files (*.xls; *.xlsx; *.xlsb; *.xlsm), *.xls, *.xlsx, *.xlsb; *.xslm", , "Please Choose the Destination workbook", , False)
vSourceFiles = Application.GetOpenFilename("Excel Files (*.xls; *.xlsx; *.xlsb; *.xlsm), *.xls, *.xlsx, *.xlsb; *.xslm", , "Please Choose the source workbooks", , True)
Set wbDest = Workbooks.Open(vDestFile)
Set wsDest = wbDest.Sheets(1)
If wsDest.Range("A3") = "" Then
Set rBottom = wsDest.Range("A3")
Else
Set rBottom = wsDest.Cells(wsDest.Rows.Count, 1)
End If
For iWb = LBound(vSourceFiles) To UBound(vSourceFiles)
Set wbSource = Workbooks.Open(vSourceFiles(iWb))
Set wsSource = wbSource.Sheets(1)
Set rCopy = wsSource.Range("A2")
Do
rCopy.EntireRow.Copy
rBottom.EntireRow.PasteSpecial
Set rCopy = rCopy.Offset(1, 0)
Set rBottom = rBottom.Offset(1, 0)
Loop Until rCopy.Value = ""
wbSource.Close (False)

Next iWb
wbDest.Close (True)
End Sub

[/VBA]

[gringo287]

Thank you for your patience and assistance Brian. I'll have a gander at this later

[gringo287]

Hi,

Really sorry for the very late response to your help Brian.

My pc bust last week and now i'm up and running again, my boss has put this project on hold, to concentrate on another.

I'll mark this as solved now as i'm sure your contribution will work fine, when i can get back to it.

[BrianMH]

No problem. Been a busy week for me too. Started a new job!

[gringo287]

Good for you, what is it