XL 2016 Extraction de données

[apt]

Bonjour,

Dans le code en PJ, l'extraction se fait un surplus d'une ligne vide.

J'ai essayé de l’éviter mais voila pas moyen.

Quelqu'un a-t-il l'idée qui m’échappe ou dois-je coder simple de ce qui a été présenté ?

Merci pour votre aide.

 

[TooFatBoy]

Bonjour,

Peut-être ceci :

        ' Récupérer les sous-catégories
        ReDim SousCategories(0 To Fin - Debut - 1)
        For i = 0 To Fin - Debut - 1
            SousCategories(i) = Cells(Debut + 1 + i, "B").Value
        Next i

 

[Dranreb]

Bonsoir.
Je l'aurais écrit comme ça, moi :

Sub RecupererDonnees()
   Dim TDon(), TRés(), LR&, LD&, TypeCategorie As String, Categorie As String
   TDon = [B4].Resize([B1000000].End(xlUp).Row - 3, 3).Value
   ReDim TRés(1 To UBound(TDon, 1), 1 To 3)
   TRés(1, 1) = "Type Catégorie": TRés(1, 2) = "Catégorie": TRés(1, 3) = "Sous-catégorie"
   LR = 1
   For LD = 1 To UBound(TDon, 1)
      If TDon(LD, 3) <> "" Then
         TypeCategorie = TDon(LD, 3)
         Categorie = TDon(LD, 1)
      ElseIf TDon(LD, 1) <> "" Then
         LR = LR + 1
         TRés(LR, 1) = TypeCategorie
         TRés(LR, 2) = Categorie
         TRés(LR, 3) = TDon(LD, 1)
         End If
      Next LD
   [K3:M1000000].ClearContents
   [K3].Resize(LR, 3).Value = TRés
   End Sub

 

[apt]

Bonsoir TooFatBoy, Dranreb,

Merci pour vos réponses

TooFatBoy : Ça évite d'avoir une ligne vide à la fin de chaque catégorie

Dranreb : Tu as codé simple avec un traitement plus rapide

Une autre petite demande : Comment puis-je définir une couleur clair différente pour chaque catégorie extraite ?

 

[Dranreb]

J'ai un module de classe pour calculer des couleurs si ça vous intéresse.

Élaboration et utilisation de jeux de couleurs.

Mise au point facile de jeux de couleurs pour UserForm, Shape et cellules, voire images calculées. Possibilité de capturer un pixel n'importe où sur l'écran. Module de classe Couleur pour utilisation dans d'autres projets VBA.

excel-downloads.com

 

[apt]

Bonjour Drabreb,

J'ai essayé d'adapter le code et voici ce que j'ai trouvé comme solution :

Sub RecupererDonnees()
    Dim TbDonnees(), TbResultat(), LgResultat&, LgDonnee&, TypeCategorie As String, Categorie As String
    Dim Couleur As Long
    
    TbDonnees = [B4].Resize([B1000000].End(xlUp).Row - 3, 3).Value
    ReDim TbResultat(1 To UBound(TbDonnees, 1), 1 To 4)
    
    TbResultat(1, 1) = "Type Catégorie": TbResultat(1, 2) = "Catégorie": TbResultat(1, 3) = "Sous-Catégorie"
    
    LgResultat = 1: Couleur = 5
    
    For LgDonnee = 1 To UBound(TbDonnees, 1)
        If TbDonnees(LgDonnee, 3) <> "" Then
            TypeCategorie = TbDonnees(LgDonnee, 3)
            Categorie = TbDonnees(LgDonnee, 1)
            Couleur = Couleur + 1
            If Couleur > 12 Then Couleur = 5
        ElseIf TbDonnees(LgDonnee, 1) <> "" Then
            LgResultat = LgResultat + 1
            TbResultat(LgResultat, 1) = TypeCategorie
            TbResultat(LgResultat, 2) = Categorie
            TbResultat(LgResultat, 3) = TbDonnees(LgDonnee, 1)
            TbResultat(LgResultat, 4) = Couleur  'LgResultat + 4
            
        End If
    Next LgDonnee
    
    With [K3:N1000000]
        .ClearContents
        With .Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
    End With
    
    [K3].Resize(LgResultat, 4).Value = TbResultat
    MsgBox [K3].Resize(LgResultat, 4).Address
    For Each C In Range("N4:N" & LgResultat + 2)
        With Range("K" & C.Row & ":M" & C.Row).Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = C.Value                'xlThemeColorAccent5
            .TintAndShade = 0.799981688894314
            .PatternTintAndShade = 0
        End With
        C.Value = ""
    Next C
End Sub

 

[Dranreb]

Bonjour.
Il devrait être possible dans la 1ère phase de noter dans un petit tableau les numéros de lignes de changement de couleurs, C'est chaque fois LR + 1. Ça ne vous intéresse pas le calcul des couleurs avec mon objet Couleur ?

 

[apt]

Ça ne vous intéresse pas le calcul des couleurs avec mon objet Couleur ?

Non, ce n'est pas le cas, j'ai juste ce problème :

 

[Dranreb]

Ca fait ça depuis quelques temps sur tous les classeurs récupérés d'internet. C'est sûr, c'est agaçant !
Clic droit sur le fichier dans le dossier, Propriété, vous avez normalement en bas à droite une case "Débloquer", la cocher, et vous pourrez ensuite l'utiliser normalement. Ou sinon copiez le classeur vers un dossier approuvé.

 

[apt]

Bonjour Dranreb,

Merci pour l'astuce.

Ç'est vraiment du travail bien fait

Par l'occasion, ne peut-on pas réécrire ceci autrement :

        With Range("K" & C.Row & ":M" & C.Row).Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = C.Value                'xlThemeColorAccent5
            .TintAndShade = 0.799981688894314
            .PatternTintAndShade = 0
        End With