Bonjour à tous,
Je viens vers vous aujourd'hui afin de solliciter votre aide pour savoir comment modifier ma macro afin que le code que j'ai ajouté (entre les ####) et qui fonctionne (bien que lent depuis cet ajout de code !) puisse s'éxecuter sans avoir à ouvrir le classeur Contrats Etiquettés. J'ai fait plusieurs tentatives avec les nombreuses infos glanées sur le site mais je n'ai malheureusement pas réussi. Je pense que cela doit être malgré tout possible mais je sèche. Alors je vous remercie tous par avance de l'aide que vous pourrez m'appporter. Je reste à votre disposition.
Dans l'attente de vous lire.
Cordialement.
Scoobidoo.
Ps : Vous voudrez bien excuser mon "écriture" mais je ne suis pas un utilisateur très confirmé de Vba.
Je viens vers vous aujourd'hui afin de solliciter votre aide pour savoir comment modifier ma macro afin que le code que j'ai ajouté (entre les ####) et qui fonctionne (bien que lent depuis cet ajout de code !) puisse s'éxecuter sans avoir à ouvrir le classeur Contrats Etiquettés. J'ai fait plusieurs tentatives avec les nombreuses infos glanées sur le site mais je n'ai malheureusement pas réussi. Je pense que cela doit être malgré tout possible mais je sèche. Alors je vous remercie tous par avance de l'aide que vous pourrez m'appporter. Je reste à votre disposition.
Dans l'attente de vous lire.
Cordialement.
Scoobidoo.
Ps : Vous voudrez bien excuser mon "écriture" mais je ne suis pas un utilisateur très confirmé de Vba.
Code:
Sub demande_contrats()
Dim Cell As Range
Dim Cell_2 As Range
Dim Plage_2 As Range
Dim Plage As Range
Dim b As Integer
Dim c As Integer
Dim wbSour As Workbook, wsSour As Worksheet
Dim wbDest As Workbook, wsDest As Worksheet
Dim wbDest_2 As Workbook, wsDest_2 As Worksheet
Dim derLig As Long
Set wbSour = ThisWorkbook
Set wsSour = wbSour.Worksheets("Contrats")
Set Plage = wsSour.Range("Liste")
If IsEmpty(Cells(2, 1)) Then
MsgBox "Votre demande est vide."
wbSour.Save
wbSour.Close
End If
'####################################################################################
Workbooks.Open "Q:\_CONTRATS GENERAUX\Demande de Contrats\Contrats Etiquettés.xlsm"
Set wbDest_2 = ActiveWorkbook
Set wsDest_2 = ActiveWorkbook.Worksheets("Contrats")
Set Plage_2 = wsDest_2.Range("ListeNumContrats")
For Each Cell In Plage
If Len(Cell) = 1 Then
Cell = "000000" & Val(Cell)
ElseIf Len(Cell) = 2 Then
Cell = "00000" & Cell
ElseIf Len(Cell) = 3 Then
Cell = "0000" & Cell
ElseIf Len(Cell) = 4 Then
Cell = "000" & Cell
ElseIf Len(Cell) = 5 Then
Cell = "00" & Cell
ElseIf Len(Cell) = 6 Then
Cell = "0" & Cell
End If
For Each Cell_2 In Plage_2
If Val(Cell_2) = Cell.Value Then
If Cell_2.Offset(0, 2).Value = "X" Or Cell_2.Offset(0, 2).Value = "x" Then
If Cell_2.Offset(0, 3) <> "" And Cell_2.Offset(0, 4) <> "" Then
MsgBox ("Le contrat N° " & Cell.Value & " a été sorti le " & Cell_2.Offset(0, 3).Value & " par " & Cell_2.Offset(0, 4).Value & ".")
Cell.Value = ""
Exit For
ElseIf Cell_2.Offset(0, 3) <> "" And Cell_2.Offset(0, 4) = "" Then
MsgBox ("Le contrat N° " & Cell.Value & " a été sorti le " & Cell_2.Offset(0, 3).Value & " par ?.")
Cell.Value = ""
Exit For
ElseIf Cell_2.Offset(0, 3) = "" And Cell_2.Offset(0, 4) = "" Then
MsgBox ("Le contrat N° " & Cell.Value & " ne se trouve pas.")
Cell.Value = ""
Exit For
End If
ElseIf Cell_2.Offset(0, 2) = "" Then
Cell_2.Offset(0, 2) = "x"
Cell_2.Offset(0, 3) = CDate(Date)
If wsSour.Application.UserName <> "Utilisateur Windows" Then
Cell_2.Offset(0, 4) = wsSour.Application.UserName
Else
Cell_2.Offset(0, 4) = Environ("UserName")
End If
b = 0
c = 0
If Cell_2.Offset(0, -1) <> "" Then
b = b - 1
While Cell_2.Offset(b, -1) = Cell_2.Offset(0, -1)
Cell_2.Offset(b, 2) = Cell_2.Offset(0, 2)
Cell_2.Offset(b, 3) = Cell_2.Offset(0, 3)
Cell_2.Offset(b, 4) = Cell_2.Offset(0, 4)
b = b - 1
Wend
c = c + 1
While Cell_2.Offset(c, -1) = Cell_2.Offset(0, -1)
Cell_2.Offset(c, 2) = Cell_2.Offset(0, 2)
Cell_2.Offset(c, 3) = Cell_2.Offset(0, 3)
Cell_2.Offset(c, 4) = Cell_2.Offset(0, 4)
c = c + 1
Wend
Exit For
End If
End If
End If
Next Cell_2
Next Cell
wbDest_2.Save
wbDest_2.Close
'###################################################################################
Set wbSour = ThisWorkbook
Set wsSour = wbSour.Worksheets("Contrats")
Columns("A:C").Select
ActiveWorkbook.Worksheets("Contrats").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Contrats").Sort.SortFields.Add Key:=Range( _
"A2:A65526"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Contrats").Sort
.SetRange Range("A1:C65526")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Set Plage = wsSour.Range("Liste")
Workbooks.Open "Q:\_CONTRATS GENERAUX\Demande de Contrats\Envoi des demandes.xlsm"
Set wbDest = ActiveWorkbook
Set wsDest = ActiveWorkbook.Worksheets("Feuil1")
wsDest.Unprotect "lemotdepasse"
Application.ScreenUpdating = False
For Each Cell In Plage
If Cell.Offset(0, 0).Value <> "" Then
derLig = wsDest.Range("A" & Cells.Rows.Count).End(xlUp).Row + 1
wsDest.Range("A" & derLig).Select
wsDest.Range("A" & derLig).Value = UCase(Cell.Offset(0, 0).Value)
wsDest.Range("B" & derLig).Value = UCase(Cell.Offset(0, 1).Value)
If wsSour.Application.UserName <> "Utilisateur Windows" Then
wsDest.Range("C" & derLig).Value = wsSour.Application.UserName
Else
wsDest.Range("C" & derLig).Value = Environ("UserName")
End If
wsDest.Range("D" & derLig).Value = UCase(Cell.Offset(0, 2).Value)
wsDest.Range("E" & derLig) = CDate(Date)
wsDest.Range("F" & derLig) = " à " & Time
End If
Next Cell
Application.ScreenUpdating = True
wsDest.Protect "lemotdepasse", True, True, True
wbDest.Save
wbDest.Close
Set wbSour = ThisWorkbook
Set wsSour = wbSour.Worksheets("Contrats")
Range("A2:C101").ClearContents
wbSour.Save
wbSour.Close
End Sub