Macro pour archiver les valeurs sauf lignes ayant un zéro....

[Christian0258]

Bonjour à tout le forum,

Je souhaiterais, à nouveau, votre aide pour modifier cette macro, afin d'archiver les valeurs sans les lignes ayant la valeur 0 en colonne B.

Voir fichier joint.

Merci pour votre aide, si précieuse.
Bien amicalement,
Christian

 

[Lolote83]

Re : Macro pour archiver les valeurs sauf lignes ayant un zéro....

Salut Christian0258,
Avec une macro de filtre élaboré comme dans le fichier joint
@+ Lolote83

 

[Efgé]

Re : Macro pour archiver les valeurs sauf lignes ayant un zéro....

Bonjour Christian0258
En attendant une proposition par filtre une version par tableau.

Sub Archivage_2()
Dim i&, J&, Rw&, Tdata As Variant
With Sheets("Formulaire")
    Tdata = .Range(.Cells(16, 2), .Cells(.Rows.Count, 2).End(3)(1, 8))
End With
For i = LBound(Tdata, 1) To UBound(Tdata, 1)
    If Tdata(i, 1) <> 0 Then
        Rw = Rw + 1
        For J = LBound(Tdata, 2) To UBound(Tdata, 2)
            Tdata(Rw, J) = Tdata(i, J)
        Next J
    End If
Next i
    
With Sheets("Base")
    .Cells(.Rows.Count, 2).End(3)(2).Resize(Rw, UBound(Tdata, 2)).FormulaLocal = Tdata
    .Activate
End With
End Sub

Cordialement
Edit Bonjour Lolote83

 

[DoubleZero]

Re : Macro pour archiver les valeurs sauf lignes ayant un zéro....

Bonjour, Christian0258, Lolote83, Efgé , le Forum,

Une autre suggestion avec filtre automatique.

Option Explicit
Sub Valeurs_positives_archiver()
    Application.ScreenUpdating = False
    Range("e15").AutoFilter
    ActiveSheet.Range("b15:h35").AutoFilter Field:=4, Criteria1:="<>0", Operator:=xlAnd
    Range("b16:h35").SpecialCells(xlCellTypeVisible).Copy
    With Sheets("Base").Range("b" & Rows.Count).End(xlUp)(2): .PasteSpecial Paste:=xlPasteValues: _
            .Range("b2").CurrentRegion.Borders.Value = 1: End With
    Range("e15").AutoFilter
    Application.ScreenUpdating = True
End Sub

A bientôt

 

[Efgé]

Re : Macro pour archiver les valeurs sauf lignes ayant un zéro....

Re
Bonjour 00
En disant "En attendant une proposition par filtre ", je pensai à toi justement

Cordialement

 

[DoubleZero]

Re : Macro pour archiver les valeurs sauf lignes ayant un zéro....

Re-bonjour,

... En disant "En attendant une proposition par filtre ", je pensai à toi justement ...

Ah ben cha alrs ! Pour quelle raison ? Je l'utilise trp souvent ?

A bientôt

 

[Christian0258]

Re : Macro pour archiver les valeurs sauf lignes ayant un zéro....

Re, le forum, Lolote83, Efgé, DoubleZero,

Merci à vous, pour votre aide.

Lolote83, sauf erreur de ma part, mais les archivages ne se cumulent pas...
Efgé, l'archivage prend toute la feuille et pas uniquement la zone B16:H35... ?
DoubleZero, ça marche, mais j'ai oublié de préciser que les colonnes D et E (feuille Formulaire) sont masquées.

Encore merci.
A vous lire,
Christian

 

[Efgé]

Re : Macro pour archiver les valeurs sauf lignes ayant un zéro....

Re
Comme d'habitude, pourrions nous avoir un fichier exemple qui soit réellement représentatif de l'original ?
Cordialement

 

[Christian0258]

Re : Macro pour archiver les valeurs sauf lignes ayant un zéro....

Re, le forum, Efgé,

La fichier déposé, dans mon premier message est bon, il faut simplement considérer que lors de l'utilisation, les colonnes D et F sont masquées.

Mes excuses pour ce manque de précision au départ.

Bien à vous,
Christian

 

[DoubleZero]

Re : Macro pour archiver les valeurs sauf lignes ayant un zéro....

Re-bonjour,

Comme ceci ?

Option Explicit
Sub Valeurs_positives_archiver_v2()
    Application.ScreenUpdating = False
    Columns("d:e").EntireColumn.Hidden = False
    Range("b15").AutoFilter
    ActiveSheet.Range("b15:h35").AutoFilter Field:=1, Criteria1:="<>0", Operator:=xlAnd
    Range("b16:h35").SpecialCells(xlCellTypeVisible).Copy
    With Sheets("Base").Range("b" & Rows.Count).End(xlUp)(2): .PasteSpecial Paste:=xlPasteValues: _
            .Range("b2").CurrentRegion.Borders.Value = 1: End With
    Range("b15").AutoFilter
    Columns("d:e").EntireColumn.Hidden = True
    Application.ScreenUpdating = True
End Sub

A bientôt

 

[Christian0258]

Re : Macro pour archiver les valeurs sauf lignes ayant un zéro....

Re, le forum, DoubleZero,

Merci, DoubleZero, c'est parfaitement, parfait. Impeccable.

Bien à toi,
Christian

 

[job75]

Re : Macro pour archiver les valeurs sauf lignes ayant un zéro....

Bonjour Christian, Lolote83, Efgé, chère DoubleZero,

Ceci est assez simple :

Sub ArchivageSansZéro()
Feuil1.Activate 'au cas où...
With Feuil2
  .Rows("5:" & .Rows.Count).Delete 'RAZ
  On Error Resume Next 'si aucun texte
  Range("B16:B" & Rows.Count).SpecialCells(xlCellTypeConstants, 2).EntireRow.Copy .[A5]
  .Range("H5:H" & .Rows.Count).Replace "=*", [B13]
  .Activate 'facultatif
End With
End Sub

A+

 

[Christian0258]

Re : Macro pour archiver les valeurs sauf lignes ayant un zéro....

Re, le forum, job75,

Bonjour et merci, job75, ok je prends, parfait.

Bien à toi,
Christian

 

[job75]

Re : Macro pour archiver les valeurs sauf lignes ayant un zéro....

Re,

Si l'on veut faire des archivages les uns à la suite des autres :

Sub ArchivageSansZéro()
Feuil1.Activate 'au cas où...
With Feuil2
  On Error Resume Next 'si aucun texte
  Range("B16:B" & Rows.Count).SpecialCells(xlCellTypeConstants, 2).EntireRow _
    .Copy .Range("B" & .Rows.Count).End(xlUp)(2).EntireRow
  .Range("H5:H" & .Rows.Count).Replace "=*", [B13]
  .Activate 'facultatif
End With
End Sub

Avec le risque de faire 36 fois le même archivage

A+

 

[Efgé]

Re : Macro pour archiver les valeurs sauf lignes ayant un zéro....

Re

Bonjour job75

Il y a quelque chose que je ne comprend pas....
Le code de job remplace les données au fur et a mesure (EntireRow.Copy .[A5]) alors qu'il est dis

... mais les archivages ne se cumulent pas...

Pour mon code la question:

... Efgé, l'archivage prend toute la feuille et pas uniquement la zone B16:H35... ?

montre à quel point les tests ont été effetués.....

Pas grave Christian a trouvé chaussure a son pied, c'est le principal....
Cordialement