Puis-je diviser une feuille de calcul en plusieurs fichiers sur la base d'une colonne dans Excel 2007 ?

Pour la postérité, voici encore une autre macro pour s'attaquer à ce problème.

Cette macro passera par une colonne spécifiée, de haut en bas, et se divisera en un nouveau fichier chaque fois qu'une nouvelle valeur sera rencontrée. Les blancs ou les valeurs répétées sont conservés ensemble (ainsi que les lignes totales), mais les valeurs de vos colonnes doivent être triées ou uniques. Je l'ai principalement conçu pour fonctionner avec la mise en page PivotTables (une fois converti en valeurs ).

Ainsi, il n'est pas nécessaire de modifier le code ou de préparer une plage nommée. La macro commence par demander à l'utilisateur de traiter la colonne, ainsi que le numéro de la ligne à laquelle il doit commencer - c'est-à-dire sauter les en-têtes, et continue à partir de là.

Lorsqu'une section est identifiée, plutôt que de copier ces valeurs sur une autre feuille, la feuille entière est copiée sur un nouveau classeur et toutes les lignes en dessous et au-dessus de la section sont supprimées. Cela permet de conserver toutes les configurations d'impression, le formatage conditionnel, les graphiques ou tout autre élément que vous pourriez y avoir, ainsi que de conserver l'en-tête dans chaque fichier fractionné, ce qui est utile lors de la distribution de ces fichiers.

Les fichiers sont enregistrés dans un sous-dossier \Split\ avec la valeur de la cellule comme nom de fichier. Je ne l'ai pas encore testé de manière approfondie sur une variété de documents, mais il fonctionne sur mes fichiers échantillons. N'hésitez pas à l'essayer et à me faire savoir si vous avez des problèmes.

La macro peut être enregistrée sous forme d'un complément Excel (xlam) pour ajouter un bouton sur le ruban/le bouton de la barre d'outils d'accès rapide pour un accès facile.

Public Sub SplitToFiles()

' MACRO SplitToFiles
' Last update: 2019-05-28
' Author: mtone
' Version 1.2
' Description:
' Loops through a specified column, and split each distinct values into a separate file by making a copy and deleting rows below and above
'
' Note: Values in the column should be unique or sorted.
'
' The following cells are ignored when delimiting sections:
' - blank cells, or containing spaces only
' - same value repeated
' - cells containing "total"
'
' Files are saved in a "Split" subfolder from the location of the source workbook, and named after the section name.

Dim osh As Worksheet ' Original sheet
Dim iRow As Long ' Cursors
Dim iCol As Long
Dim iFirstRow As Long ' Constant
Dim iTotalRows As Long ' Constant
Dim iStartRow As Long ' Section delimiters
Dim iStopRow As Long
Dim sSectionName As String ' Section name (and filename)
Dim rCell As Range ' current cell
Dim owb As Workbook ' Original workbook
Dim sFilePath As String ' Constant
Dim iCount As Integer ' # of documents created

iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 2, , , , , 1)
iFirstRow = iRow

Set osh = Application.ActiveSheet
Set owb = Application.ActiveWorkbook
iTotalRows = osh.UsedRange.Rows.Count
sFilePath = Application.ActiveWorkbook.Path

If Dir(sFilePath + "\Split", vbDirectory) = "" Then
    MkDir sFilePath + "\Split"
End If

'Turn Off Screen Updating Events
Application.EnableEvents = False
Application.ScreenUpdating = False

Do
    ' Get cell at cursor
    Set rCell = osh.Cells(iRow, iCol)
    sCell = Replace(rCell.Text, " ", "")

    If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
        ' Skip condition met
    Else
        ' Found new section
        If iStartRow = 0 Then
            ' StartRow delimiter not set, meaning beginning a new section
            sSectionName = rCell.Text
            iStartRow = iRow
        Else
            ' StartRow delimiter set, meaning we reached the end of a section
            iStopRow = iRow - 1

            ' Pass variables to a separate sub to create and save the new worksheet
            CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
            iCount = iCount + 1

            ' Reset section delimiters
            iStartRow = 0
            iStopRow = 0

            ' Ready to continue loop
            iRow = iRow - 1
        End If
    End If

    ' Continue until last row is reached
    If iRow < iTotalRows Then
            iRow = iRow + 1
    Else
        ' Finished. Save the last section
        iStopRow = iRow
        CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
        iCount = iCount + 1

        ' Exit
        Exit Do
    End If
Loop

'Turn On Screen Updating Events
Application.ScreenUpdating = True
Application.EnableEvents = True

MsgBox Str(iCount) + " documents saved in " + sFilePath

End Sub

Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)

Dim rngRange As Range
Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow
rngRange.Select
rngRange.Delete

End Sub

Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
     Dim ash As Worksheet ' Copied sheet
     Dim awb As Workbook ' New workbook

     ' Copy book
     osh.Copy
     Set ash = Application.ActiveSheet

     ' Delete Rows after section
     If iTotalRows > iStopRow Then
         DeleteRows ash, iStopRow + 1, iTotalRows
     End If

     ' Delete Rows before section
     If iStartRow > iFirstRow Then
         DeleteRows ash, iFirstRow, iStartRow - 1
     End If

     ' Select left-topmost cell
     ash.Cells(1, 1).Select

     ' Clean up a few characters to prevent invalid filename
     sSectionName = Replace(sSectionName, "/", " ")
     sSectionName = Replace(sSectionName, "\", " ")
     sSectionName = Replace(sSectionName, ":", " ")
     sSectionName = Replace(sSectionName, "=", " ")
     sSectionName = Replace(sSectionName, "*", " ")
     sSectionName = Replace(sSectionName, ".", " ")
     sSectionName = Replace(sSectionName, "?", " ")
     sSectionName = Strings.Trim(sSectionName)

     ' Save in same format as original workbook
     ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat

     ' Close
     Set awb = ash.Parent
     awb.Close SaveChanges:=False
End Sub

Pour autant que je sache, il n'y a rien de moins qu'une macro qui va diviser vos données et les enregistrer automatiquement dans un ensemble de fichiers pour vous. La VBA est probablement plus simple.

Mise à jour J'ai mis en œuvre ma suggestion. Elle passe en boucle tous les noms définis dans la plage nommée “RepList”. L'intervalle de noms est un intervalle de noms dynamique de la forme =OFFSET(Noms!$A$2,0,0,COUNTA(Noms!$A:$A)-1,1)

module suit.

Option Explicit

'Split sales data into separate columns baed on the names defined in
'a Sales Rep List on the 'Names' sheet.
Sub SplitSalesData()
    Dim wb As Workbook
    Dim p As Range

    Application.ScreenUpdating = False

    For Each p In Sheets("Names").Range("RepList")
        Workbooks.Add
        Set wb = ActiveWorkbook
        ThisWorkbook.Activate

        WritePersonToWorkbook wb, p.Value

        wb.SaveAs ThisWorkbook.Path & "\salesdata_" & p.Value
        wb.Close
    Next p
    Application.ScreenUpdating = True
    Set wb = Nothing
End Sub

'Writes all the sales data rows belonging to a Person
'to the first sheet in the named SalesWB.
Sub WritePersonToWorkbook(ByVal SalesWB As Workbook, _
                          ByVal Person As String)
    Dim rw As Range
    Dim personRows As Range 'Stores all of the rows found
                                'containing Person in column 1
    For Each rw In UsedRange.Rows
        If Person = rw.Cells(1, 1) Then
            If personRows Is Nothing Then
                Set personRows = rw
            Else
                Set personRows = Union(personRows, rw)
            End If
        End If
    Next rw

    personRows.Copy SalesWB.Sheets(1).Cells(1, 1)
    Ser personRows = Nothing
End Sub

Ce cahier contient le code et la plage nommée. Le code fait partie de la fiche “Données sur les ventes”.

Si quelqu'un d'autre répond avec la bonne façon de procéder qui est rapide, veuillez ignorer cette réponse.

Je me retrouve personnellement à utiliser Excel et à passer beaucoup de temps (parfois des heures) à chercher une façon compliquée de faire quelque chose ou une équation exagérée qui fera tout quand je ne l'utiliserai plus jamais… et il s'avère que si je m'asseyais et que je me mettais à la tâche manuellement, cela ne prendrait qu'une fraction du temps.

Si vous n'avez qu'une poignée de personnes, ce que je vous recommande de faire, c'est de simplement surligner toutes les données, d'aller dans l'onglet des données et de cliquer sur le bouton de tri.

Vous pouvez alors choisir la colonne par laquelle vous voulez trier, dans votre cas vous voulez utiliser Repname, puis simplement copier et coller dans les fichiers individuels.

Je suis sûr qu'en utilisant VBA ou d'autres outils, vous pourrez trouver une solution, mais le fait est que vous allez devoir travailler pendant des heures et des heures alors que le simple fait de vous y mettre en utilisant la méthode ci-dessus devrait vous permettre de le faire en un rien de temps.

Aussi, je pense que vous pouvez faire ce genre de choses sur les services sharepoint + excel, mais c'est une solution qui dépasse largement le cadre de ce genre de choses.

Bon, voici la première coupe de la VBA. Vous l'appelez comme ça :

SplitIntoFiles Range("A1:N1"), Range("A2:N2"), Range("B2"), "Split File - "

Où A1:N1 est votre (vos) ligne(s) d'en-tête, A2:N2 est la première ligne de vos données, B2 est la première cellule de votre colonne clé pré-triée. Le dernier argument est le préfixe du nom de fichier. La clé sera ajoutée à celui-ci avant la sauvegarde.

Avertissement : ce code est désagréable.

Option Explicit
Public Sub SplitIntoFiles(headerRange As Range, startRange As Range, keyCell As Range, filenameBase As String)

    ' assume the keyCell column is already sorted

    ' start a new workbook
    Dim wb As Workbook
    Dim ws As Worksheet

    Set wb = Application.Workbooks.Add
    Set ws = wb.ActiveSheet

    Dim destRange As Range
    Set destRange = ws.Range("A1")

    ' copy header
    headerRange.Copy destRange
    Set destRange = destRange.Offset(headerRange.Rows.Count)

    Dim keyValue As Variant
    keyValue = ""

    While keyCell.Value <> ""

        ' if we've got a new key, save the file and start a new one
        If (keyValue <> keyCell.Value) Then
        If keyValue <> "" Then
            'TODO: remove non-filename chars from keyValue
            wb.SaveAs filenameBase & CStr(keyValue)
            wb.Close False
            Set wb = Application.Workbooks.Add
            Set ws = wb.ActiveSheet
            Set destRange = ws.Range("A1")

            ' copy header
            headerRange.Copy destRange
            Set destRange = destRange.Offset(headerRange.Rows.Count)

            End If
        End If

        keyValue = keyCell.Value

        ' copy the contents of this row to the new sheet
        startRange.Copy destRange

        Set keyCell = keyCell.Offset(1)
        Set destRange = destRange.Offset(1)
        Set startRange = startRange.Offset(1)
    Wend

    ' save residual
    'TODO: remove non-filename chars from keyValue
    wb.SaveAs filenameBase & CStr(keyValue)
    wb.Close

End Sub

Je trie par nom et je colle les informations directement dans une deuxième feuille Excel, celle que vous voulez envoyer. Excel ne colle que les lignes que vous voyez, pas les lignes cachées. Je protège également toutes les cellules, sauf celles que je veux qu'elles mettent à jour. lol.