Modif ,sur macro pour archiver les valeurs d'une zone et sans lignes vides...

Christian0258

XLDnaute Accro
Re, Bonsoir à tout le forum,

J'ai à nouveau besoin d'aide sur lune macro ci-dessous.
Cette macro archive une zone définie vers un autre classeur.
Mon problème :
-comment modifier pour n'archiver que les valeurs
- et n'archiver que les lignes renseignées et non les lignes vides :

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

Sub TransfertQtéFicheTechn()
Dim Wb1 As Workbook
Dim WB2 As Workbook
Dim Plg As Range, Derlgin As Long
If Range("g3") = 0 Then
MsgBox "Aucune denrée saisie....", , "Erreur"
Exit Sub
End If
Application.ScreenUpdating = False
Set Wb1 = ThisWorkbook
Set WB2 = Workbooks.Open("C:\ARCHIVES DONNEES FICHES TECHNIQUES\DonnéesFichesTechniques.xls.xlsx")
Set Plg = Wb1.Sheets("FICHE TECHNIQUE").Range("CK17:CU" & Wb1.Sheets("FICHE TECHNIQUE").Range("CK32").End(xlUp).Row)
With WB2.Sheets("Archives")
derlign = .Range("A65536").End(xlUp).Row
.Range("M" & derlign + 1) = "Sauvegarde du " & Format(Date, "dd-mm-yyyy") & " à " & Time
Plg.Copy .Range("A" & derlign + 1) 'comment modifier pour ne copier que les valeurs et sans lignes vides
.Columns("A:L").AutoFit
End With
WB2.Save
WB2.Close
Application.ScreenUpdating = True
End Sub
 

job75

XLDnaute Barbatruc
Re : Modif ,sur macro pour archiver les valeurs d'une zone et sans lignes vides...

Bonsoir Christian,

Remplacer :

Code:
Plg.Copy .Range("A" & derlign + 1)
par :

Code:
Dim i
With .Range("A" & derlign + 1).Resize(Plg.Rows.Count, 11)
  .Value = Plg.Value
  For i = Plg.Rows.Count To 1 Step -1
    If Application.CountA(.Rows(i)) = 0 Then .Rows(i).Delete xlUp
  Next
End With
Bien entendu pas testé.

A+
 

kjin

XLDnaute Barbatruc
Re : Modif ,sur macro pour archiver les valeurs d'une zone et sans lignes vides...

bonsoir,
Code:
Sub TransfertQtéFicheTechn()
Dim wB1 As Workbook, wB2 As Workbook
Dim Plg As Range, dL As Long
If Range("g3") = 0 Then
    MsgBox "Aucune denrée saisie....", , "Erreur"
    Exit Sub
End If
Application.ScreenUpdating = False
Set wB1 = ThisWorkbook
With wB1.Sheets("FICHE TECHNIQUE")
    Set Plg = .Range("CK17:CU" & .Range("CK32").End(xlUp).Row)
End With
Set wB2 = ("C:\ARCHIVES DONNEES FICHES TECHNIQUES\DonnéesFichesTechniques.xls.xlsx")
With wB2.Sheets("Archives")
    dL = .Range("A65536").End(xlUp).Row + 1
    .Range("M" & dL) = "Sauvegarde du " & Format(Date, "dd-mm-yyyy") & " à " & Time
    For i = 1 To Plg.Rows.Count
        If Application.CountA(Plg.Rows(i)) <> 0 Then
            dL = dL + 1
            .Range("A" & dL).Resize(1, Plg.Columns.Count) = Plg.Rows(i).Value
        End If
    Next
    .Columns("A:L").AutoFit
End With
wB2.Close True
Application.ScreenUpdating = True
End Sub
A+
kjin
 

Discussions similaires

Statistiques des forums

Discussions
312 103
Messages
2 085 314
Membres
102 860
dernier inscrit
fredo67