Amélioration / Modification de code

Scoobidoo · 25 Février 2014

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.

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

jpb388 · 2 Mars 2014

Re : Amélioration / Modification de code

Bonjour à tous
Je ne l'ai pas testé donc prend les précautions d'usage a savoir la testé sur une copie de tes fichiers

Code:

Option Explicit

Sub demande_contrats()
Dim Cell As Range, Cell_2 As Range, Plage_2 As Range, Plage As Range
Dim b As Integer, c As Integer, derLig As Long
Dim wbSour As Workbook, wbDest As Workbook, wbDest_2 As Workbook
Dim wsSour As Worksheet, wsDest As Worksheet, wsDest_2 As Worksheet

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
    Cell = Format(Cell, "0#####")
    For Each Cell_2 In Plage_2
        Select Case Cell_2.Value
            Case Is = Cell.Value
                Select Case Cell_2.Offset(0, 2).Value
                    Case Is = "X", Is = "x"
                        Select Case Cell_2.Offset(0, 3)
                            Case Is <> ""
                                Select Case Cell_2.Offset(0, 4)
                                    Case Is <> ""
                                        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
                                    Case Is = ""
                                        MsgBox ("Le contrat N° " & Cell.Value & " a été sorti le " _
                                        & Cell_2.Offset(0, 3).Value & " par ?.")
                                        Cell.Value = ""
                                        Exit For
                                End Select ' Cell_2.Offset(0, 4)
                        Case Is = "" 'Cell_2.Offset(0, 3)
                            Select Case Cell_2.Offset(0, 4)
                                Case Is = ""
                                MsgBox ("Le contrat N° " & Cell.Value & " ne se trouve pas.")
                                Cell.Value = ""
                                Exit For
                            End Select ' Cell_2.Offset(0, 4)
                        End Select 'Cell_2.Offset(0, 3)
                Case Is = ""
                    Cell_2.Offset(0, 2) = "x"
                    Cell_2.Offset(0, 3) = CDate(Date)
                    Cell_2.Offset(0, 4) = IIf(wsSour.Application.UserName <> "Utilisateur Windows" _
                    , wsSour.Application.UserName, Environ("UserName"))
                    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 Select ' Cell_2.Offset(0, 2).Value
        End Select ' Cell_2.Value
    Next Cell_2
Next Cell
wbDest_2.Save
wbDest_2.Close

'###################################################################################

Set wbSour = ThisWorkbook
Set wsSour = wbSour.Worksheets("Contrats")
With ActiveWorkbook.Worksheets("Contrats").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("A2:A65526"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange Range("A1:C65526")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
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)
        wsDest.Range("C" & derLig).Value = IIf(wsSour.Application.UserName <> "Utilisateur Windows" _
                                        , wsSour.Application.UserName, Environ("UserName"))
        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

Effectuez une recherche sur Excel Downloads...

Amélioration / Modification de code

Scoobidoo

XLDnaute Occasionnel

jpb388

XLDnaute Accro

Discussions similaires

Nous accordons de l'importance à votre vie privée