macro ne fonctionne pas, vérification ouverture fichier

[Jacques25]

Bonjour à tous,

J'ai créé un code avec l'aide du forum afin de :
- vérifier si 3 fichiers sont ouverts
- si un des fichiers est ouvert, envoi d'un mail sans rien faire
- sinon ouverture, mise à jour et fermeture

Je pensai que ça marchai mais ce matin je me suis rendu que je demandai l'ouverture du fichier avant de vérifier s'il était ouvert. J'ai essayé des modifications mais je m'y perd un peu.

Voici mon code, pouvez vous m'aider à remettre dans le bon ordre (j'ai enlever la partie envoi mail en dessous du 10)

Private Sub Majfichier_Click()

'Identification des variables
Dim lien As String, fichier(1 To 3), i As Integer

'Détermination des variables
lien = "\\seurveura\b\c\"
fichier(1) = "Récl Q.xls"
fichier(2) = "Récl L.xls"
fichier(3) = "Récl a.xls"
Set Source = Workbooks("BDF.xlsm").Worksheets("Feuil1")
nbl = Source.[D3].End(xlDown).Row - 2
Dim ouvert As Boolean, ouvert2 As Boolean, ouvert3 As Boolean

'Passage en calcul manuel
With Application
.Calculation = xlManual
End With

'Boucle sur les 3 fichiers
For i = 1 To 3

'Ouverture du fichier
Workbooks.Open (lien & "\" & fichier(i))
Set cible = Workbooks(fichier(i)).Worksheets("adresse fournisseurs")
'Test si fichiers ouverts
ouvert = False
ouvert2 = False
ouvert3 = False
For Each wkb In Workbooks
If wkb.Name = "Récl Q.xls" Then
ouvert = True
End If
If wkb.Name = "Récl L.xls" Then
ouvert2 = True
End If
If wkb.Name = "Récl a.xls" Then
ouvert3 = True
End If
Exit For
Next
'Si fichier(s) ouvert(s) go vers envoi mail
If ouvert = True Or ouvert2 = True Or ouvert3 = True Then
GoTo 10
End If

'Suppression protection et RAZ cellules de destination
cible.Unprotect Password:="XXX"
cible.Range("A3:Y1000").ClearContents

'Copie des données de source vers fichiers cibles
Source.[A3].Resize(nbl, 25).Copy Destination:=cible.[A3]

'Passage en calcul auto
Application.Calculation = xlAutomatic

'Remise en place protection
cible.Protect UserInterfaceOnly:=True, Password:="XXX", Scenarios:=True, AllowFormattingRows:=True

'tri des fournisseurs par ordre alphabétique dans les fichiers cibles
cible.AutoFilter.Sort.SortFields. _
Clear
cible.AutoFilter.Sort.SortFields. _
Add Key:=Range("E2:E800"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With cible.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Workbooks(fichier(i)).Save
Workbooks(fichier(i)).Close
Next i
10
...

Merci à tous de l'aide que vous pourrez m'apporter.

@ plus

Jacques

 

[Jacques25]

Re : macro ne fonctionne pas, vérification ouverture fichier

Re-bonjour tout le monde,

Une info que j'ai pas donné, il s'agit d'un fichier en réseau et la vérification doit permettre de savoir si un des fichiers est ouvert sur un autre PC.

Voilà je pense qu'il fallait le préciser.

En attendant d'éventuelles réponses je vous remercie.

Jacques

 

[gilbert_RGI]

Re : macro ne fonctionne pas, vérification ouverture fichier

Bonjour

procédure à tester remettre le chemin de votre réseau à la plce de mon chemin

j'ai volontairement remé les fonctions de tri à remettre en place

Sub test()

'Identification des variables
Dim lien As String, fichier(1 To 3), i As Integer
'Détermination des variables
lien = "C:\dossier_agarder"
fichier(1) = "Récl Q.xls"
fichier(2) = "Récl L.xls"
fichier(3) = "Récl a.xls"
Set Source = Workbooks("BDF.xlsm").Worksheets("Feuil1")
nbl = Source.[D3].End(xlDown).Row - 2
Dim ouvert As Boolean, ouvert2 As Boolean, ouvert3 As Boolean
'Passage en calcul manuel
With Application
.Calculation = xlManual
End With
ouvert = False
ouvert2 = False
ouvert3 = False
'Boucle sur les 3 fichiers
For i = 1 To 3
'Ouverture du fichier
Workbooks.Open (lien & "\" & fichier(i))
Set cible = Workbooks(fichier(i)).Worksheets("adresse fournisseurs")
'Test si fichiers ouverts
MsgBox "Ouverture de " & fichier(i)
If fichier(i) = "Récl Q.xls" Then
ouvert = True
GoTo maj
End If
If fichier(i) = "Récl L.xls" Then
ouvert2 = True
GoTo maj
End If
If fichier(i) = "Récl a.xls" Then
ouvert3 = True
GoTo maj
End If

'Si fichier(s) ouvert(s) go vers envoi mail
GoTo 10
' End If
maj:
'Suppression protection et RAZ cellules de destination
cible.Unprotect Password:="XXX"
cible.Range("A3:Y1000").ClearContents

'Copie des données de source vers fichiers cibles
Source.[A3].Resize(nbl, 25).Copy Destination:=cible.[A3]

'Passage en calcul auto
Application.Calculation = xlAutomatic
'Remise en place protection
cible.Protect UserInterfaceOnly:=True, Password:="XXX", Scenarios:=True, AllowFormattingRows:=True

'tri des fournisseurs par ordre alphabétique dans les fichiers cibles
' cible.AutoFilter.Sort.SortFields. _
Clear
' cible.AutoFilter.Sort.SortFields. _
Add Key:=Range("E2:E800"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
' With cible.AutoFilter.Sort
'.Header = xlYes
' .MatchCase = False
'.Orientation = xlTopToBottom
'.SortMethod = xlPinYin
'.Apply
' End With
Workbooks(fichier(i)).Save
If ouvert = True Or ouvert2 = True Or ouvert3 = True Then MsgBox "procédure pour Envoi email......"

Workbooks(fichier(i)).Close
Next i
10:
If ouvert = True Or ouvert2 = True Or ouvert3 = True Then MsgBox "les fichiers ont été mis à jour et envoyés"
End Sub