Copier les plages répondant à un critère après un tri vba

CVC

XLDnaute Nouveau
Bonjour,

Je sèche sur la récupération de plages de valeurs répondant à un critère après un tri.
J'ai cherché à récupérer les valeurs dans une variable tableau qui m'aurait ensuite permis de copier les dites valeurs sur un fichier excel vierge (un fichier pour chaque plage de valeurs enregistré au nom de ce critère).
La variable tableau Copi sur fichier ne me fourni pas les données et je ne comprend pas d'ou vient mon erreur.
Merci aux âmes charitables qui pourraient m'aider !
 

Fichiers joints

BOISGONTIER

XLDnaute Barbatruc
Re : Copier les plages répondant à un critère après un tri vba

Bonjour,

cf PJ

Code:
Sub CreeClasseurs()
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  [A1].CurrentRegion.Sort key1:=[B2], key2:=[D2], Header:=xlYes
  [A1:D10000].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[g1], Unique:=True
  For Each c In Range("G2", Range("G65000").End(xlUp))
     Range("G2") = c
     Sheets.Add
     Sheets("BD").[A1:D10000].AdvancedFilter Action:=xlFilterCopy, _
         CriteriaRange:=Sheets("BD").[G1:G2], CopyToRange:=[A1], Unique:=False
       ActiveSheet.Copy
       ActiveSheet.Name = c
       ActiveWorkbook.SaveAs Filename:=c
       ActiveWorkbook.Close
       ActiveSheet.Delete
       Sheets("BD").Select
    Next c
End Sub
JB
 

Fichiers joints

Paf

XLDnaute Barbatruc
Re : Copier les plages répondant à un critère après un tri vba

Bonjour CVC, BOISGONTIER,

une version tableau pour tenter de finaliser les essais de CVC
Code:
Sub DémoPilot()
 Dim i As Long, x As Long, y  As Long, z As Long, t As Long, derlig As Long, dercol As Long, num As Long
 Dim IndicePrec As Long, lin As Long, j As Byte
 Dim Copi(), tableur()
 Dim xlApp As Excel.Application
 Dim xlSheet As Excel.Worksheet
 Dim xlBook As Excel.Workbook

 Application.ScreenUpdating = False
 With k1
 For lin = .Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1  'boucle inverse sur feuille k1 pr suppression des lignes vides
    If .Rows(lin).Find("*") Is Nothing Then .Rows(lin).Delete 'si absence de valeur dans la ligne alors on la supprime
 Next lin
 
    z = Application.Match("Date émission", .Rows(1), 0) 'permet de retrouver n°colonne Date émission en ligne 1, sécurise ainsi le filtre
    y = Application.Match("raison sociale titulaire", .Rows(1), 0) 'permet de retrouver n°colonne raison sociale en ligne 1, sécurise ainsi le filtre
    derlig = .Range(.Cells(1, y), .Cells(65536, y)).End(xlDown).Row + 1 'definit la dernière ligne non vide de la colonne qui fait apparaitre raison sociale titulaire
    dercol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column 'définit la dernière colonne non vide sur ligne 1
    
   .Range(.Cells(1, 1), .Cells(derlig, dercol)).Sort key1:=.Cells(1, y), order1:=xlAscending, key2:=.Cells(1, z), order2:=xlAscending, Header:=xlYes 'tri sur 2 critères (raison social et date)en ordre croissant

   tableur = .Range(.Cells(2, 1), .Cells(derlig, dercol)) 'enregistrement de la BD en tableau VBA (ligne 2 car les 1ère données se trouvent en général sur celle-ci !)
 End With

 IndicePrec = 0

 For i = 1 To UBound(tableur, 1) - 1 'du début de ligne du tableau a la dernière valeur - 1 (dimension 1)
    If tableur(i, y) <> tableur(i + 1, y) Then 'si la raison sociale change alors
        num = i                                'num égal le dernier indice du tableau vba
        ReDim Copi(1 To num - IndicePrec, 1 To dercol) 'création d'un tableau variable propre à chaque plage de données
        For t = IndicePrec + 1 To num   'du début de chaque plage(n°ligne) à la fin(n°ligne)
            x = x + 1 ' Indice du tableau copi
            For j = 1 To dercol
                Copi(x, j) = tableur(t, j)        'Copi integrera en valeur 1 les premières données de chaque plage
            Next j
        Next t
        
        '****** copie dans nouveau classeur ************
        Set xlBook = Workbooks.Add  'ouvrir un nouvel excel
        'xlApp.Visible = False   'le rendre invisible

        With xlBook.Worksheets("Feuil2")
            .Range("A2").Resize(UBound(Copi, 1), UBound(Copi, 2)) = Copi
        End With
        xlBook.SaveAs ThisWorkbook.Path & "\" & Copi(1, 4) & ".xls"
        xlBook.Close
        Set xlBook = Nothing
        '********* fin copie ***************************
        
        x = 0 'RAZ indice Copi
        IndicePrec = i ' mémorisation de la dernière ligne de la plage qui deviendra premiere ligne de plage suivante
    End If
 Next i
 Application.ScreenUpdating = True
End Sub
et une autre version basée sur le même principe mais sans tableau
Code:
Sub DémoPilotV2()
 Dim i As Long, y As Long, z As Long, derlig As Long, dercol As Long
 Dim IndicePrec As Long, lin As Long
 Dim xlBook As Excel.Workbook
 Dim WSource
 
 Set WSource = ThisWorkbook.Worksheets("Feuil1")
 
 Application.ScreenUpdating = False
 With WSource
 For lin = .Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1  'boucle inverse sur feuille k1 pr suppression des lignes vides
    If .Rows(lin).Find("*") Is Nothing Then .Rows(lin).Delete 'si absence de valeur dans la ligne alors on la supprime
 Next lin
 
 z = Application.Match("Date émission", .Rows(1), 0) 'permet de retrouver n°colonne Date émission en ligne 1, sécurise ainsi le filtre
 y = Application.Match("raison sociale titulaire", .Rows(1), 0) 'permet de retrouver n°colonne raison sociale en ligne 1, sécurise ainsi le filtre
 derlig = .Range(.Cells(1, y), .Cells(65536, y)).End(xlDown).Row + 1 'definit la dernière ligne non vide de la colonne qui fait apparaitre raison sociale titulaire
 dercol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column 'définit la dernière colonne non vide sur ligne 1
    
 .Range(.Cells(1, 1), .Cells(derlig, dercol)).Sort key1:=.Cells(1, y), order1:=xlAscending, key2:=.Cells(1, z), order2:=xlAscending, Header:=xlYes 'tri sur 2 critères (raison social et date)en ordre croissant

 IndicePrec = 1

 For i = 2 To derlig - 1 'du début de ligne du tableau a la dernière valeur - 1 (dimension 1)
    If .Cells(i, y) <> .Cells(i + 1, y) Then 'si la raison sociale change alors
        '****** copie dans nouveau classeur ************
        Set xlBook = Workbooks.Add  'ouvrir un nouvel excel
        Range(.Cells(IndicePrec + 1, 1), .Cells(i, dercol)).Copy _
         Destination:=Worksheets("Feuil2").Range("A2")
        xlBook.SaveAs ThisWorkbook.Path & "\" & .Cells(i, 4) & ".xls"
        xlBook.Close
        Set xlBook = Nothing
        '********* fin copie ***************************
        IndicePrec = i ' mémorisation de la dernière ligne de la plage qui deviendra premiere ligne de plage suivante
    End If
 Next i
 End With
 Application.ScreenUpdating = True
End Sub
à tester

A+
 

Discussions similaires


Haut Bas