recuperer des donnees via des criteres

[tigeline001]

Bonjour tout le monde
J'ai un problème
le code ci-joint marche très bien ,je demande s'il y a possibilité de le modifier et de l'adapter avec la methode sur les filtres ou autre chose pour que ca se charge tres rapidement.Actuellement ya pas bcp de donnees mais si je mets un fichier de 6000lignes ca prend plusieurs minutes pour se charger

Je veux juste une autre methode pour charger rapidement les feuilles DIS_Laval et DIS_Quebec
Merci

 

[jp14]

Re : recuperer des donnees via des criteres

Bonjour

Pour diminuer le temps de traitement il ne faut pas travailler sur les feuilles excel. On transfère la plage de cellules dans un tableau, on travaille avec les donnéees du tableau et une fois terminé on fait l'inverse.
Ci dessous un exemple

Dim MonTab1 As Variant, Compt11 As Long, Plg1 As Range
col1= "a"
With Sheets(ActiveSheet.Name)
'la colonne A est transféré dans un tableau 
    Set Plg1 = .Range(Col1 & "1:" & Col1 & .Range(Col1 & .Rows.Count).End(xlUp).Row)
    MonTab1 = Plg1.Value
'on realise le traitement
    For Compt11 = LBound(MonTab1, 1) To UBound(MonTab1, 1)
         ' par exemple
         MonTab1(Compt11, 1)=Trim(MonTab1(Compt11, 1)) 
   
    Next Compt11

'une fois terminé le résultat est transféré dans la feuille

Plg1.Value = MonTab1
End With

Code à adapter au problème

Bonne journée

JP

 

[tigeline001]

Re : recuperer des donnees via des criteres

Bonjour JP
Merci de votre aide
Comme je suis débutant en VBA ,j 'ai essayé d'adapter votre code à mon problème mais ça passe pas,j'ai des conditions et plusieurs colonnes à transférer
Merci

 

[jp14]

Re : recuperer des donnees via des criteres

Bonjour (re)

Un exemple pour la feuille " Dis laval" . a tester sur une copie, modification de la casse et suppression de donnée.

Il faut travailler sur une plage

Sub test()
Dim MonTab1 As Variant, Compt11 As Long, Plg1 As Range

With Sheets(ActiveSheet.Name)
    Set Plg1 = .Range("A2:N" & .Range("A" & .Rows.Count).End(xlUp).Row)
     MonTab1 = Plg1.Value
         For Compt11 = LBound(MonTab1, 1) To UBound(MonTab1, 1)
         ' colonne E en majuscule
             MonTab1(Compt11, 4) = UCase(MonTab1(Compt11, 4))' colonne 4
             MonTab1(Compt11, 5) = UCase(MonTab1(Compt11, 5))'colonne 5
             MonTab1(Compt11, 14) = Left(MonTab1(Compt11, 14), 2)' colonne 14
        Next Compt11
        
 Plg1.Value = MonTab1
End With
     
    
End Sub

 

[tigeline001]

Re : recuperer des donnees via des criteres

Bonjour JP
je l'ai modifié mais il me retourne juste le titre

 Sub test()
Dim MonTab1 As Variant, Compt11 As Long, Plg1 As Range

  With Feuil1    'Déclaration implicite de l'objet feuil1
    lig = 2
    With Feuil4
    .Cells(1, 1) = "Intervention": .Cells(1, 2) = "Conclusion": .Cells(1, 3) = "Code": .Cells(1, 4) = "Genre_Intervention": .Cells(1, 5) = "Statut": .Cells(1, 6) = "Date_début": .Cells(1, 7) = "Date_fin": .Cells(1, 8) = "Code_Inspecteur": .Cells(1, 9) = "Anomalie": .Cells(1, 10) = "Numero_demande": .Cells(1, 11) = "Date_Creation_Demande": .Cells(1, 12) = "Nom_Inspecteur": .Cells(1, 13) = "Prenom_Inspecteur": .Cells(1, 14) = "Domaine_Intervention"
      .Rows(1).Font.Bold = True
      End With
        For i = 2 To .UsedRange.Rows.Count    'traitement de la ligne 2 à la dernière ligne non vide
            Z = .Cells(i, 13) & Chr(32) & .Cells(i, 12)    'dans la variable z j'écris le nom et prénom séparé par un espace
           Set trouve = Feuil2.Columns(3).Find(Z, lookat:=xlWhole)    'j'indique de rechercher la valeur de z dans la colonne 2
            If Not trouve Is Nothing Then    'si un résultat est trouvé
         For Compt11 = LBound(MonTab1, 1) To UBound(MonTab1, 1)
             MonTab1(Compt11, 4) = MonTab1(Compt11, 4) ' colonne 4
             MonTab1(Compt11, 5) = MonTab1(Compt11, 5) 'colonne 5
             MonTab1(Compt11, 14) = MonTab1(Compt11, 14) ' colonne 14
             
        Next Compt11
        End If
        Next i
 Plg1.Value = MonTab1
End With
     
    
End Sub

Merci

 

[jp14]

Re : recuperer des donnees via des criteres

Bonjour

Un code à tester

'Option Explicit

Private Sub traitement()
Dim MonTab1 As Variant, Compt11 As Long, Plg1 As Range
Dim MonTab2 As Variant, Compt12 As Long, Plg2 As Range
Dim MonTab3 As Variant, Compt13 As Long, Plg3 As Range
Dim quoi$, z As String, Trouve As Boolean, Dl1 As Long
Feuil3.Cells.Delete 'j'efface la feuille transfere


With Sheets("REC_DIS") ' Feuil1    'Déclaration implicite de l'objet feuil1
    Dl1 = .Range("A" & .Rows.Count).End(xlUp).Row
    Set Plg1 = .Range("A2:N" & Dl1)
     MonTab1 = Plg1.Value
End With
'Entête

With Sheets("DIS_Laval") ',Feuil4
    .Cells(1, 1) = "Intervention": .Cells(1, 2) = "Conclusion": .Cells(1, 3) = "Code": .Cells(1, 4) = "Genre_Intervention": .Cells(1, 5) = "Statut": .Cells(1, 6) = "Date_début": .Cells(1, 7) = "Date_fin": .Cells(1, 8) = "Code_Inspecteur": .Cells(1, 9) = "Anomalie": .Cells(1, 10) = "Numero_demande": .Cells(1, 11) = "Date_Creation_Demande": .Cells(1, 12) = "Nom_Inspecteur": .Cells(1, 13) = "Prenom_Inspecteur": .Cells(1, 14) = "Domaine_Intervention"
      .Rows(1).Font.Bold = True
    Set Plg2 = .Range("A2:N" & Dl1)'les tableaux doivent avoir la même dimention
    MonTab2 = Plg2.Value
End With

With Sheets("Liste_service")
    Set Plg3 = .Range("c4:D" & .UsedRange.Rows.Count)
    MonTab3 = Plg3.Value

     For Compt11 = LBound(MonTab1, 1) To UBound(MonTab1, 1)
         z = MonTab1(Compt11, 13) & Chr(32) & MonTab1(Compt11, 12) 'prénom nom
         Trouve = False
            For Compt13 = LBound(MonTab3, 1) To UBound(MonTab3, 1)
               If MonTab3(Compt13, 1) = z Then
                   Trouve = True
                   Exit For
               End If
            Next Compt13
         If Trouve = True Then
            For i = 1 To 14
                MonTab2(Compt11, i) = MonTab1(Compt11, i)
            Next i
         End If
    Next Compt11
   Plg2 = MonTab2
   Suprimer2 "DIS_Laval"
    'je cloture la déclaration implicite


With Sheets("DIS_Laval")
 .Activate
 .Columns("A:Y").AutoFit: .Range("A1").CurrentRegion.Borders.LineStyle = 1 'J'ajuste mes colonnes en tailles
End With

End Sub

'Procedure pour supprimer les lignes vides  
Private Sub Suprimer2(Nomfeuille1 As String)
Dim Cel1 As Range, S1 As Worksheet, Li1 As Long, Li2 As Long
On Error GoTo Suprimer2_Error
Application.EnableEvents = False
If Nomfeuille1 <> "" Then
    Set S1 = Worksheets(Nomfeuille1)
    Set Cel1 = S1.Range("a:a").SpecialCells(xlCellTypeBlanks)
    Cel1.EntireRow.Delete Shift:=xlUp
End If
On Error GoTo 0
Application.EnableEvents = True
Suprimer2_Error:
End Sub

Bonne journée

JP

 

[tigeline001]

Re : recuperer des donnees via des criteres

Bonjour JP
j'ai trouvé une solution et ca marche
Merci encore

Private Sub Worksheet_Activate()
Dim MonTab1 As Variant, Compt11 As Long, Plg1 As Range, Plg2 As Range
Dim j As Long

With Feuil1
.Range("A1:N1").Copy Feuil4.Range("A1")
    Set Plg1 = .Range("A2:N" & .Range("A" & .Rows.Count).End(xlUp).Row)
     MonTab1 = Plg1.Value
     j = 2
         For Compt11 = LBound(MonTab1, 1) To UBound(MonTab1, 1)
        Z = .Cells(Compt11, 13) & Chr(32) & .Cells(Compt11, 12)
         'Z = MonTab1(Compt11, 13) & Chr(32) & MonTab1(Compt11, 12)
         Set trouve = Feuil2.Columns(4).Find(Z, lookat:=xlWhole)
         If Not trouve Is Nothing Then
             MonTab1 = Feuil1.Range("A" & Compt11 & ":N" & Compt11)
             With Feuil4
    Set Plg2 = .Range("A" & j & ":N" & j)
        'Set Plg2 = .Range("A1:N1")
    Plg2.Value = MonTab1

    End With
             j = j + 1
            End If
        Next Compt11
 End With


    
End Sub