Copier-Coller a plusieurs ds un classeur reseau meme en lecture seule

[pic.sous]

Bonjour à tous,

J’ai besoin de votre aide pour résoudre un problème sur lequel je planche depuis déjà 3 semaines.
J’ai crée une macro me permet de copier d’une Feuille X des data dans une Feuille Y.
Tout ce passe bien quand :
1. Une personne travaille sur Feuille X pour envoyer les data dans Feuille Y
2. Deux feuille travailles sur Feuille X (dont une en lecture seule) pour envoyer les data dans Feuille Y. L'envoie ne se fait pas en même temps.
Par contre GROS problème quand:
Deux ou plusieurs personnes travailles sur Feuille X et envoient en même temps des data dans Feuille Y alors la, la macro bug pour une des personnes.
1. Je voudrais votre aide pour savoir comment permettre a plusieurs personnes d’envoyer les donnés en même temps dans la Feuille Y sans que la macro bug.
2. Pensez-vous que le fait de dire à la macro d’ouvrir la Feuille Y pour y copier les éléments rende la macro plus lente ?
Merci beaucoup beaucoup pour votre aide.
Pics.


Sub ExportData()

Application.ScreenUpdating = False

Dim i As Integer
Dim j As String

ChDir "S:\xxxxxxxxx"
NomFichier = "Feuille Y.xls"
Workbooks.Open Filename:=NomFichier
Sheets("y").Select

Workbooks("Feuille X'.xls").Activate
Sheets("x").Select

Range("A1").Select

For i = 1 To 1

If ActiveCell.Value = "" Then
ActiveCell.Offset(1, 0).Select

Else

If ActiveCell.Value = "MACRO" Then
ActiveCell.Offset(2, 0).Select

Else
j = ActiveCell.Address
ActiveCell.Offset(0, 3).Select
Range("D1 : Q1").Select
Selection.Copy

Workbooks("Feuille Y.xls").Activate
Sheets("y").Select

Range("B2").Select

While ActiveCell <> ""
ActiveCell.Offset(1, 0).Select
Wend
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Workbooks("Feuille X.xls").Activate
Sheets("x").Select
Range(j).Select
ActiveCell.Offset(2, 0).Select

End If

End If

Next i

Application.CutCopyMode = False

Workbooks("Feuille Y.xls").Activate
Sheets("y").Select
ActiveWorkbook.Save
ActiveWorkbook.Close

Workbooks("Feuille X.xls").Activate
Sheets("x").Select

Range("A1").Select

End Sub