mise au point et fin d'une macro

Question

Bonjour, 
pouvez vous m'aider à mettre au point cette macro "TRANSFERT"
1/Le traitement est  conditionné par une égalité entre les cellules  et B4 et D4.
En cas d'inégalité, je dois afficher un message (msgbox) pour abandonner le traitement et sortir de la macro

2/elle sélectionne les lignes de ENCOURS dont la notif (col H) = référence en A4
(3 lignes répondent à cette sélection)

3/Ces 3 lignes sont transférées dans l'onglet HISTO à partir de la 1ère ligne vide dispo.

4/on tri ce fichier HISTO enrichi de 3 nouvelles lignes
en l'état, la macro est triée sur H4 : je n'arrive pas à trouver la syntaxe pour ajouter les 3 critères suivants qui sont en commentaire.

L'exécution de cette macro fonctionne pour les cas 2 et 3 et le tri mono-critère.
le cas 1 affiche : variable non définie pour B4 et D4

merci de votre coup de main
sm

https://www.cjoint.com/c/FFkxsgu1xxe

Frenchie83 · Answer

Bonjour
Pour le test de B4 et D4, mettre entre crochets 
Pour le tri, utilisez l'enregistreur de macro
Après MsgBox, pas de signe =

Option Explicit
Dim num_lign, lign_disp, DerLig

Sub Transfert()
    If [B4] = [D4] Then                                                             'égalité montant rlv et montant progressif
        For num_lign = 6 To Range("A" & Rows.Count).End(xlUp).Row               'on délimite la plage de ENCOURS
            If Range("H" & num_lign) = Range("A4") Then                             'on sélectionne les n° de relevé
                lign_disp = Sheets("HISTO").Range("A" & Rows.Count).End(xlUp)(2).Row      'position sur 1ere ligne dispo de HISTO
                Range("A" & num_lign & ":K" & num_lign).Copy Sheets("HISTO").Range("A" & lign_disp) 'copy la ligne ENCOURS sur HISTO
                Range("A" & num_lign & ":K" & num_lign).Delete Shift:=xlUp          'suppression cette ligne sur ENCOURS
            End If
        Next num_lign
        
        'tri sur HISTO
        Sheets("HISTO").Select
        DerLig = [A1000000].End(xlUp).Row
        With Range("A4:K" & DerLig).Select
            ActiveWorkbook.Worksheets("HISTO").Sort.SortFields.Clear
            ActiveWorkbook.Worksheets("HISTO").Sort.SortFields.Add Key:=Range("H4:H" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            ActiveWorkbook.Worksheets("HISTO").Sort.SortFields.Add Key:=Range("A4:A" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            ActiveWorkbook.Worksheets("HISTO").Sort.SortFields.Add Key:=Range("G4:G" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            ActiveWorkbook.Worksheets("HISTO").Sort.SortFields.Add Key:=Range("J4:J" & DerLig), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With ActiveWorkbook.Worksheets("HISTO").Sort
                .SetRange Range("A4:K" & DerLig)
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
        End With
    Else
        MsgBox "terminer pointage en cours - abandon du transfert"             'message abandon et sortie du transfert
    End If
End Sub
Cdlt

Mise au point et fin d'une macro

1 réponse

Discussions similaires

Newsletters