VBA : Extraction de données vers une nouvelle feuille ou fichier selon critère

Mappie · 3 Janvier 2015

Bonjour,

J'ai une base de données où je souhaiterais, à l'aide de macros, reporter les données correspondant à un critère sur un nouvel onglet ou qui aurait pour nom celui du critère.

Dans mon cas précis: j'ai des chiffres pour 3 villes : Paris, Marseille et Lyon. Je cherche à produire 2 types de macros:

1) Créer une macro où, pour chaque ville, copier-coller les données relatives à cette ville sur un nouvel onglet en supprimant la colonne ville et en ajoutant en bas de chaque colonne son total.

2) Créer une autre macro qui à partir d'un inputbox, avec liste déroulante contenant les 3 villes, reporter les données de la ville choisie avec les totaux de chaque colonne dans un nouveau fichier.

Je pense qu'il faut mettre des conditions en stockant les données dans des variables de type tableaux mais je ne sais pas trop comment le modéliser pour créer un onglet pour chaque ville.

De même pour créer un imptubox, je ne sais pas s'il faut passer par un formulaire.

Je vous remercie par avance pour votre aide.

MP59 · 3 Janvier 2015

Re : VBA : Extraction de données vers une nouvelle feuille ou fichier selon critère

Bonjour Mappie,
voici une réponse pour le1)
Meilleurs vœux à tous.
MP59

Yaloo · 3 Janvier 2015

Re : VBA : Extraction de données vers une nouvelle feuille ou fichier selon critère

Bonsoir Mappie, MP59,

Une autre approche avec des filtres plutôt que des boucles de suppression.
Pour le 2, je n'ai pas compris ta demande.

A+

Martial

Mappie · 3 Janvier 2015

Re : VBA : Extraction de données vers une nouvelle feuille ou fichier selon critère

Je vous remercie MP59 et Martial pour votre aide sur la macro 1, cela correspond parfaitement à ce que je recherche. C'est super!

Sur la macro 2, je souhaiterais :
- Lancer un inputbox avec comme texte par exemple : "Sélectionner la ville" et au lieu de taper la réponse, avoir une liste déroulante avec les 3 villes à savoir Lyon, Marseille, Paris.
- En fonction de la ville choisie, copier-coller dans un autre fichier les données relatives à ce critère avec les totaux.

Je ne sais pas si cela est possible, mais je vous remercie encore pour les réponses que vous m'avez déjà apportées. Cela va me faire gagner beaucoup de temps.

Bonne soirée

Yaloo · 3 Janvier 2015

Re : VBA : Extraction de données vers une nouvelle feuille ou fichier selon critère

Re,

Voici avec l'export vers le classeur du nom de la ville.

A+

Martial

klin89 · 4 Janvier 2015

Re : VBA : Extraction de données vers une nouvelle feuille ou fichier selon critère

Bonsoir à tous,

En gardant les données comme présentées en feuille "Export"
Question : à quoi servent ces colonnes vides dans ton tableau ?

VB:

Sub Recopie()
Dim a, i As Long, j As Long, w(), x, y, txt As String
    Application.ScreenUpdating = False
    'a = Sheets("Export").Range("B3").CurrentRegion.Value
    'a = Sheets("Export").Range("B3", Sheets("Export").Cells.SpecialCells(11)).Value
    With Sheets("Export").Range("B3", Sheets("Export").Cells.SpecialCells(11))
        a = Application.Index(.Value, Evaluate("row(1:" & _
                    .Rows.Count & ")"), Array(1, 2, 3, 4, 6, 7, 9))
    End With
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            txt = a(i, 1)
            If Not .exists(txt) Then .Item(txt) = Empty
            If IsEmpty(.Item(txt)) Then
                ReDim w(1 To UBound(a, 2), 1 To 1)
            Else
                w = .Item(txt)
                ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
            End If
            For j = 1 To UBound(a, 2)
                w(j, UBound(w, 2)) = a(i, j)
            Next
            .Item(txt) = w
        Next
        x = .keys: y = .items
    End With
    For i = 0 To UBound(x)
        On Error Resume Next
        Application.DisplayAlerts = False
        Sheets(x(i)).Delete
        On Error GoTo 0
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = x(i)
        With Sheets(x(i)).Cells(1).Resize(, UBound(a, 2))
            .Value = a
            .Offset(1).Resize(UBound(y(i), 2)).Value = _
            Application.Transpose(y(i))
        End With
        With Sheets(x(i)).Cells(1).CurrentRegion
            With .Offset(.Rows.Count).Resize(1)
                .Formula = "=sum(r2c:r[-1]c)"
                .Cells(1) = "Totaux"
                '.Cells(5) = "": .Cells(8) = ""
                .BorderAround Weight:=xlThin
                .Interior.ColorIndex = 19
            End With
            With .Rows(1)
                .Interior.ColorIndex = 44
                .BorderAround Weight:=xlThin
            End With
            With .Resize(.Rows.Count + 1)
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
                .Borders(xlInsideVertical).Weight = xlThin
                .BorderAround Weight:=xlThin
                .EntireColumn.AutoFit
            End With
        End With
    Next
    Application.ScreenUpdating = True
End Sub

Klin89

klin89 · 6 Janvier 2015

Re : VBA : Extraction de données vers une nouvelle feuille ou fichier selon critère

Re Mappie,

Quelques ajustements :

VB:

Sub Recopie()
Dim a, i As Long, j As Long, w(), x, y, txt As String
    Application.ScreenUpdating = False
    'a = Sheets("Export").Range("B3").CurrentRegion.Value
    'a = Sheets("Export").Range("B3", Sheets("Export").Cells.SpecialCells(11)).Value
    With Sheets("Export").UsedRange
        a = Application.Index(.Value, Evaluate("row(1:" & _
                                               .Rows.Count & ")"), Array(2, 3, 4, 6, 7, 9, 1))
    End With
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            txt = a(i, 7)
            If Not .exists(txt) Then .Item(txt) = Empty
            If IsEmpty(.Item(txt)) Then
                ReDim w(1 To UBound(a, 2), 1 To 1)
            Else
                w = .Item(txt)
                ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
            End If
            For j = 1 To UBound(a, 2)
                w(j, UBound(w, 2)) = a(i, j)
            Next
            .Item(txt) = w
        Next
        x = .keys: y = .items
    End With
    For i = 0 To UBound(x)
        On Error Resume Next
        Application.DisplayAlerts = False
        Sheets(x(i)).Delete
        On Error GoTo 0
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = x(i)
        With Sheets(x(i)).Cells(1).Resize(, UBound(a, 2) - 1)
            .Value = a
            .Offset(1).Resize(UBound(y(i), 2)).Value = _
            Application.Transpose(y(i))
        End With
        With Sheets(x(i)).Cells(1).CurrentRegion
            With .Offset(.Rows.Count).Resize(1)
                .Formula = "=sum(r2c:r[-1]c)"
                .BorderAround Weight:=xlThin
                .Interior.ColorIndex = 19
            End With
            With .Rows(1)
                .Interior.ColorIndex = 44
                .BorderAround Weight:=xlThin
            End With
            With .Resize(.Rows.Count + 1)
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
                .Borders(xlInsideVertical).Weight = xlThin
                .BorderAround Weight:=xlThin
                .EntireColumn.AutoFit
            End With
        End With
    Next
    Application.ScreenUpdating = True
End Sub

klin89

VBA : Extraction de données vers une nouvelle feuille ou fichier selon critère

Mappie

XLDnaute Junior

Pièces jointes

MP59

XLDnaute Occasionnel

Pièces jointes

Yaloo

XLDnaute Barbatruc

Pièces jointes

Mappie

XLDnaute Junior

Yaloo

XLDnaute Barbatruc

Pièces jointes

klin89

XLDnaute Accro

klin89

XLDnaute Accro

Discussions similaires

VBA : Extraction de données vers une nouvelle feuille ou fichier selon critère

Mappie

XLDnaute Junior

Pièces jointes

MP59

XLDnaute Occasionnel

Pièces jointes

Yaloo

XLDnaute Barbatruc

Pièces jointes

Mappie

XLDnaute Junior

Yaloo

XLDnaute Barbatruc

Pièces jointes

klin89

XLDnaute Accro

klin89

XLDnaute Accro

Discussions similaires

Privacy & Transparency

Privacy & Transparency