Extraire données d'un tableau pour créer un autre tableau

[damaelyon]

Bonjour à tous,

Je débute en programmation VBA et j'ai besoin de votre aide.

J'ai créé avec l'aide d'un membre de ce forum un tableau permettant "l'éclatement" de données du premier onglet sur plusieurs onglets en fonction d'une données présente en colonne O de ce premier onglet.

La macro est déjà présente dans le fichier joint.

J'aimerais maintenant pouvoir "envoyer" certaines données vers un nouveau classeur mais à des positions bien précises.

Dans le deuxième onglet de mon exemple, j'ai mis la correspondance entre les données source et cellules cibles.

Le but est de créer un bouton pour chaque ligne permettant d'envoyer les données de chaque ligne à volonté vers un nouveau fichier.

J'ai essayé beaucoup de choses mais ça ne marche pô.

Merci d'avance pour votre aide.

 

[JCGL]

Re : Extraire données d'un tableau pour créer un autre tableau

Bonjour à tous,

Un click sur le Go ventile par item de la Colonne 14 :

Option Explicit


Sub Ventile()
    Dim CurCell As Range, Titre As Range


    Application.ScreenUpdating = 0


    Columns("A:N").Sort Key1:=Range("N2"), Order1:=xlAscending, Header:=xlGuess
    Range("A1").Select


    Set CurCell = ThisWorkbook.Sheets("2012_Global").Range("N1")
    Set Titre = ThisWorkbook.Sheets("2012_Global").Range("A1:N1")


    While CurCell.Value <> vbNullString
        With GetSheet(CurCell.Value)
            Titre.EntireRow.Copy .Cells(1, 1)
            CurCell.EntireRow.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
        End With
        Set CurCell = CurCell.Offset(1, 0)
        Columns("A:N").Columns.AutoFit
    Wend


    Application.DisplayAlerts = 0
    Sheets("Colonne 14").Delete
    Application.DisplayAlerts = 1
    Sheets("2012_Global").Activate
End Sub


Public Function GetSheet(SheetName As String) As Worksheet
    Dim CurSheet As Worksheet, Exist As Boolean
    Exist = False
    For Each CurSheet In ThisWorkbook.Sheets
        If CurSheet.Name = SheetName Then Exist = True
    Next CurSheet
    If Not Exist Then
        ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = SheetName
    End If
    Set GetSheet = ThisWorkbook.Worksheets(SheetName)
End Function

A + à tous