2009-10-19 03:49:07 +0000 2009-10-19 03:49:07 +0000
9
9

Czy mogę podzielić arkusz kalkulacyjny na wiele plików na podstawie kolumny w programie Excel 2007?

Czy istnieje sposób w Excelu, aby podzielić duży plik na serię mniejszych, na podstawie zawartości pojedynczej kolumny?

np: Mam plik z danymi sprzedaży dla wszystkich przedstawicieli handlowych. Muszę wysłać im plik, aby nanieśli poprawki i odesłali, ale nie chcę wysyłać każdemu z nich całego pliku (ponieważ nie chcę, aby zmieniali swoje dane). Plik wygląda mniej więcej tak:

salesdata.xls

RepName Customer ContactEmail
Adam Cust1 admin@cust1.com
Adam Cust2 admin@cust2.com
Bob Cust3 blah@cust3.com
etc...

z tego potrzebuję:

salesdata_Adam.xls

RepName Customer ContactEmail
Adam Cust1 admin@cust1.com
Adam Cust2 admin@cust2.com

oraz salesdata_Bob.xls

Bob Cust3 blah@cust3.com

Czy w Excelu 2007 jest coś wbudowanego, żeby zrobić to automatycznie, czy mam wyrwać VBA?

Odpowiedzi (5)

8
8
8
2012-03-05 04:10:01 +0000

Dla potomności, oto kolejne makro, które rozwiązuje ten problem.

To makro przejdzie przez określoną kolumnę, z góry na dół, i podzieli ją do nowego pliku, gdy tylko napotka nową wartość. Puste lub powtarzające się wartości są zachowywane razem (tak samo jak wszystkie wiersze), ale wartości w kolumnach muszą być posortowane lub unikalne. Zaprojektowałem go głównie do pracy z układem tabel przestawnych (po konwersji na wartości ](https://stackoverflow.com/questions/5708548/excel-vba-pivottable-to-values-with-fill-blanks-what-about-compact-rows)).

Tak jak jest, nie ma potrzeby modyfikować kodu ani przygotowywać zakresu nazw. Makro rozpoczyna się od zapytania o kolumnę do przetworzenia oraz numer wiersza, od którego ma się rozpocząć - czyli pominąć nagłówki, i od tego momentu przechodzi dalej.

Po zidentyfikowaniu sekcji, zamiast kopiować te wartości do innego arkusza, cały arkusz jest kopiowany do nowego skoroszytu, a wszystkie wiersze poniżej i powyżej sekcji są usuwane. Pozwala to na zachowanie wszelkich ustawień drukowania, formatowania warunkowego, wykresów lub czegokolwiek innego, co można tam mieć, jak również zachowanie nagłówka w każdym podzielonym pliku, co jest przydatne przy dystrybucji tych plików.

Pliki są zapisywane w podfolderze z wartością komórki jako nazwą pliku. Nie testowałem go jeszcze na różnych dokumentach, ale działa na moich przykładowych plikach. Zachęcam do wypróbowania go i poinformowania mnie o ewentualnych problemach.

Makro może być zapisane jako dodatek do Excela (xlam), aby dodać przycisk na wstążce/przycisku paska narzędzi szybkiego dostępu dla łatwego dostępu.

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
6
6
6
2009-10-19 03:53:42 +0000

O ile wiem, nie ma nic krótszego niż makro, które podzieli dane i automatycznie zapisze je na zestaw plików dla Ciebie. VBA jest prawdopodobnie łatwiejsze.

Uaktualnienie Wdrożyłem moją sugestię. Przechodzi on przez wszystkie nazwy zdefiniowane w nazwanym zakresie “RepList”. Zakres nazwany jest dynamicznym zakresem nazwanym w postaci =OFFSET(Names!$A$2,0,0,COUNTA(Names!$A:$A)-1,1)

moduł następuje.

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

Ten skoroszyt zawiera kod i nazwany zakres. Kod jest częścią arkusza “Dane sprzedaży”.

2
2
2
2009-10-19 03:59:17 +0000

Jeśli ktoś inny odpowie z poprawnym sposobem robienia tego, który jest szybki, proszę zignorować tę odpowiedź.

Osobiście uważam, że używam Excela, a następnie spędzam dużo czasu (czasami godzin) szukając skomplikowanego sposobu na zrobienie czegoś lub nadmiernego równania, które zrobi wszystko, gdy nigdy więcej go nie użyję … i okazuje się, że gdybym po prostu usiadł i zajął się zadaniem ręcznie, zajęłoby to ułamek czasu.


Jeśli masz tylko garstkę osób, to co polecam zrobić, to po prostu zaznaczyć wszystkie dane, przejść do zakładki dane i kliknąć przycisk sortowania.

Następnie możesz wybrać kolumnę, według której chcesz sortować, w twoim przypadku chcesz użyć Repname, a następnie po prostu skopiować i wkleić do poszczególnych plików.

Jestem pewien, że używając VBA lub innych narzędzi, możesz wymyślić rozwiązanie, ale faktem jest, że będziesz patrzył na wiele godzin pracy, gdy po prostu zajmiesz się tym, używając powyższej metody, która powinna sprawić, że zrobisz to w krótkim czasie.

Myślę też, że możesz zrobić coś takiego na sharepoint + excel services, ale jest to rozwiązanie dla tego typu rzeczy.

1
1
1
2009-10-19 20:13:28 +0000

OK, więc oto pierwszy wycinek VBA. Wywołujesz go w ten sposób:

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

Gdzie A1:N1 to twój wiersz(y) nagłówkowy, A2:N2 to pierwszy wiersz twoich danych, B2 to pierwsza komórka w twojej wstępnie posortowanej kolumnie kluczowej. Ostatnim argumentem jest prefiks nazwy pliku. Klucz zostanie do niego dołączony przed zapisem.

Zastrzeżenie: ten kod jest paskudny.

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
-2
-2
-2
2012-12-11 08:32:17 +0000

Sortuję według nazwisk i wklejam informacje prosto do drugiego arkusza Excela, tego, który chcesz wysłać. Excel wkleja tylko te wiersze, które widzisz, a nie ukryte wiersze. Chronię również wszystkie komórki z wyjątkiem komórek, które chcę, aby zostały zaktualizowane. lol.