Kan ik in Excel 2007 een spreadsheet in meerdere bestanden splitsen op basis van een kolom?

Voor het nageslacht, hier is nog een macro om dit probleem aan te pakken.

Deze macro zal door een gespecificeerde kolom gaan, van boven naar beneden, en splitsen naar een nieuw bestand telkens wanneer een nieuwe waarde wordt aangetroffen. Blanco’s of herhaalde waarden worden bij elkaar gehouden (net als het totaal aantal rijen), maar je kolomwaarden moeten gesorteerd of uniek zijn. Ik heb het in de eerste plaats ontworpen om te werken met de opmaak van PivotTables (eenmaal geconverteerd naar waarden ).

Dus zoals het is, is het niet nodig om de code aan te passen of een benoemde reeks voor te bereiden. De macro begint met de gebruiker te vragen om de kolom die verwerkt moet worden, alsmede het rijnummer waarmee begonnen moet worden - dat wil zeggen om de koppen over te slaan, en gaat van daaruit verder.

Wanneer een sectie is geïdentificeerd, wordt in plaats van die waarden naar een ander werkblad te kopiëren, het hele werkblad naar een nieuwe werkmap gekopieerd en worden alle rijen onder en boven de sectie verwijderd. Dit maakt het mogelijk om alle afdrukken setup, voorwaardelijke opmaak, grafieken of wat dan ook je zou kunnen hebben in daar, evenals het houden van de header in elk gesplitst bestand, dat is handig bij het verspreiden van deze bestanden te houden.

De bestanden worden opgeslagen in een submap met de celwaarde als bestandsnaam. Ik heb het nog niet uitgebreid getest op een verscheidenheid aan documenten, maar het werkt op mijn voorbeeldbestanden. Probeer het gerust uit en laat het me weten als je problemen ondervindt.

De macro kan worden opgeslagen als een excel add-in (xlam) om een knop op het lint/sneltoegang werkbalk toe te voegen voor gemakkelijke toegang.

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

Voor zover ik weet is er niets minder dan een macro die je gegevens opsplitst en automatisch in een reeks bestanden voor je opslaat. VBA is waarschijnlijk gemakkelijker.

Update Ik heb mijn suggestie geïmplementeerd. Het loopt door alle namen die gedefinieerd zijn in het genoemde bereik ‘RepList’. De genoemde reeks is een dynamische genoemde reeks van de vorm =OFFSET(Namen!$A$2,0,0,COUNTA(Namen!$A:$A)-1,1)

module volgt.

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

Deze werkmap bevat de code en het genoemde bereik. De code maakt deel uit van het blad “Verkoopgegevens”.

Als iemand anders antwoord met de juiste manier om dit te doen die snel is, negeer dan dit antwoord.

Ik gebruik Excel en ben dan veel tijd (soms uren) kwijt met het zoeken naar een ingewikkelde manier om iets te doen of een over-the-top vergelijking die alles doet terwijl ik het nooit meer zal gebruiken… en dan blijkt dat als ik gewoon ging zitten en de taak handmatig zou uitvoeren, het een fractie van de tijd zou kosten.

• *

Als je maar een handjevol mensen hebt, wat ik je aanraad te doen is gewoon alle gegevens markeren, naar het tabblad gegevens gaan en op de knop sorteren klikken.

Je kunt dan kiezen op welke kolom je wilt sorteren, in jouw geval wil je Repname gebruiken, en dan gewoon kopiëren en plakken naar individuele bestanden.

Ik weet zeker dat je met VBA of andere tools een oplossing kunt vinden, maar het feit is dat je dan uren werk hebt, terwijl je met de bovenstaande methode in een mum van tijd klaar zou moeten zijn.

Ik denk ook dat je dit soort dingen op Sharepoint + Excel Services kunt doen, maar dat is een veel te hoge oplossing voor dit soort dingen.

OK, dus hier is het eerste deel van de VBA. Je roept het als volgt aan:

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

Waar A1:N1 je header rij(en) is, A2:N2 is de eerste rij van je gegevens, B2 is de eerste cel in je voorgesorteerde key kolom. Het laatste argument is de prefix van de bestandsnaam. De sleutel zal hieraan worden toegevoegd alvorens op te slaan.

Disclaimer: deze code is smerig.

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

Ik sorteer op naam en plak de informatie rechtstreeks in een tweede Excel-blad, het blad dat u wilt verzenden. Excel plakt alleen de regels die je ziet, niet ook de verborgen rijen. Ik bescherm ook alle cellen behalve de cellen die ik wil updaten. lol.