Extraction en valeur dans un nouveau fichier

Question

J’aurais besoin de votre aide pour une macro que je n’arrive pas à réaliser. Je voudrais extraire en valeur les onglets « Analyse1 » et « Analyse2 » du fichier en pj (qui est un exemple) dans un nouveau classeur et cela pour chaque entreprise. Donc obtenir un nouveau fichier dans lequel on retrouve : Un onglet analyse1 et analyse2 avec les données de l’entreprise A Un onglet analyse1 et analyse2 avec les données de l’entreprise B Un onglet analyse1 et analyse2 avec les données de l’entreprise C Etc … Tout cela dans le meme fichier. Et si possible renommer à chaque fois les onglets « analyse1 » et « analyse2 » par le nom de l’entreprise. Je reste à votre disposition si besoin. Merci beaucoup pour votre aide Cordialement, CGS RH...

m3ellem1 · Answer

Salut CGS-RH,

un essai qu'on peut developper aprés

en créant un nouveau fichier:

Sub Extraction_Valeurs1()
    Dim i As Long, j As Long, lastrow As Long
    Dim entreprise As String
    Dim sheetIndex As Integer
    Dim NewBook As Workbook, Y  As Workbook

    sheetIndex = 1
    Set NewBook = Workbooks.Add
    Set Y = ThisWorkbook
Application.ScreenUpdating = False
    With Y.Sheets("infos1")
    lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
        For i = 5 To lastrow
        entreprise = .Cells(i, 2).Value
        Y.Sheets("Analyse1").Cells(5, 3).Value = entreprise
            For j = 1 To 2
            Y.Sheets("Analyse" & j).Copy before:=NewBook.Sheets(sheetIndex)
            Sheets(sheetIndex).Name = "Analyse" & j & "_" & entreprise
            Application.CutCopyMode = False
            sheetIndex = sheetIndex + 1
            Next j
          ActiveSheet.ChartObjects("Chart 2").Activate
          ActiveChart.SetSourceData Source:=Sheets("Analyse1_" & entreprise).Range("B9:C11")
        Next i
    End With

Application.ScreenUpdating = True
ActiveWorkbook.Close savechanges:=True
End Sub

Dans le même fichier:

Sub Extraction_Valeurs2()
Dim i As Long, j As Long, lastrow As Long
Dim entreprise As String

Application.ScreenUpdating = False
    With Sheets("infos1")
    lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
        For i = 5 To lastrow
        entreprise = .Cells(i, 2).Value
        Sheets("Analyse1").Cells(5, 3).Value = entreprise
            For j = 1 To 2
            Sheets("Analyse" & j).Copy After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = "Analyse" & j & "_" & entreprise
            Application.CutCopyMode = False
            Next j
            ActiveSheet.ChartObjects("Chart 2").Activate
       ActiveChart.SetSourceData Source:=Sheets("Analyse1_" & entreprise).Range("B9:C11")
        Next i
    End With
Application.ScreenUpdating = True
End Sub