Tipy aplikace Excel: Rozdělte data do více listů / sešitů na základě hodnoty sloupce

Při správě velkých datových sad v Excelu může být velmi užitečné rozdělit data do více listů na základě konkrétních hodnot sloupců. Tato metoda zlepšuje nejen organizaci dat, ale také zlepšuje čitelnost a usnadňuje analýzu dat.

Předpokládejme, že máte velký záznam o prodeji obsahující více položek, jako je název produktu, prodané množství za první čtvrtletí. Cílem je rozdělit tato data do samostatných listů na základě každého názvu produktu, aby bylo možné analyzovat jednotlivé prodejní výkony samostatně.

Rozdělte data do více listů na základě hodnoty sloupce

• Pomocí kódu VBA
• Pomocí výkonné funkce - Kutools pro Excel

Rozdělte data do více sešitů na základě hodnoty sloupce pomocí kódu VBA

Rozdělte data do více listů na základě hodnoty sloupce

Obvykle můžete seznam dat nejprve seřadit a poté je zkopírovat a vložit jeden po druhém do dalších nových listů. To však bude vyžadovat vaši trpělivost, abyste je mohli opakovaně kopírovat a vkládat. V této části představíme dvě jednoduché metody, jak efektivně zvládnout tento úkol v Excelu, což vám ušetří čas a sníží možnost chyb.

Rozdělte data do více listů na základě hodnoty sloupce pomocí kódu VBA

1. Podržte stisknuté tlačítko ALT + F11 klávesy pro otevření Microsoft Visual Basic pro aplikace okno.

2. cvaknutí Vložit > Modula vložte následující kód do okna modulu.

Sub Splitdatabycol()
'updateby Extendoffice
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim xTRg As Range
Dim xVRg As Range
Dim xWSTRg As Worksheet
Dim xWS As Worksheet
On Error Resume Next
Set xTRg = Application.InputBox("Please select the header rows:", "Kutools for Excel", "", Type:=8)
If TypeName(xTRg) = "Nothing" Then Exit Sub
Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Kutools for Excel", "", Type:=8)
If TypeName(xVRg) = "Nothing" Then Exit Sub
vcol = xVRg.Column
Set ws = xTRg.Worksheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = xTRg.AddressLocal
titlerow = xTRg.Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
Application.DisplayAlerts = False
If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
Else
Sheets("xTRgWs_Sheet").Delete
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
End If
Set xWSTRg = Sheets("xTRgWs_Sheet")
xTRg.Copy
xWSTRg.Paste Destination:=xWSTRg.Range("A1")
ws.Activate
For i = (titlerow + xTRg.Rows.Count) To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Set xWS = Sheets.Add(after:=Worksheets(Worksheets.Count))
xWS.Name = myarr(i) & ""
Else
xWS.Move after:=Worksheets(Worksheets.Count)
End If
xWSTRg.Range(title).Copy
xWS.Paste Destination:=xWS.Range("A1")
ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy xWS.Range("A" & (titlerow + xTRg.Rows.Count))
Sheets(myarr(i) & "").Columns.AutoFit
Next
xWSTRg.Delete
ws.AutoFilterMode = False
ws.Activate
Application.DisplayAlerts = True
End Sub

3. Poté stiskněte F5 pro spuštění kódu a zobrazí se okno s výzvou, které vám připomene vybrat řádek záhlaví a poté klepněte OK. Viz snímek obrazovky:

4. Ve druhém řádku výzvy vyberte data sloupce, podle kterých chcete rozdělit, a poté klepněte OK. Viz snímek obrazovky:

5. Všechna data v aktivním listu jsou rozdělena do více listů na základě hodnot sloupců. Výsledné listy jsou pojmenovány podle hodnot v rozdělených buňkách a jsou umístěny na konci sešitu. Viz snímek obrazovky:

Rozdělte data do více listů na základě hodnoty sloupce pomocí Kutools pro Excel

Kutools pro Excel přináší chytrou funkci – Rozdělit data přímo do vašeho prostředí Excelu. Rozdělení dat do více listů již není problém. Náš intuitivní nástroj automaticky rozdělí vaši datovou sadu na základě zvolené hodnoty sloupce nebo počtu řádků a zajistí, že každá informace bude přesně tam, kde ji potřebujete. Rozlučte se s únavným úkolem ručního organizování tabulek a osvojte si rychlejší a bezchybný způsob správy dat.

Po instalaci Kutools pro Excel, vyberte rozsah dat a poté klikněte na Kutools Plus > Rozdělit data k otevření Rozdělte data do více listů dialogové okno.

1. vybrat Specifický sloupec možnost v Rozdělit na základě a z rozevíracího seznamu vyberte hodnotu sloupce, podle které chcete data rozdělit.
2. Pokud vaše data mají záhlaví a chcete je vložit do každého nového rozděleného listu, zkontrolujte Moje data mají záhlaví volba. (Počet řádků záhlaví můžete určit na základě vašich dat. Pokud například vaše data obsahují dvě záhlaví, zadejte 2.)
3. Poté můžete určit názvy dělených listů pod položkou Název nového listu určete pravidlo pro názvy listů z rozevíracího seznamu Pravidla, můžete přidat Předpona or Přípona i pro názvy listů.
4. Klepněte na tlačítko OK knoflík. Viz screenshot:
   

Nyní jsou data v listu rozdělena do více listů v novém sešitu.

Rozdělte data do více sešitů na základě hodnoty sloupce pomocí kódu VBA

Někdy může být výhodnější rozdělit data do samostatných sešitů na základě klíčového sloupce než rozdělovat data do více listů. Zde je podrobný návod, jak používat kód VBA k automatizaci procesu rozdělování dat do více sešitů na základě konkrétní hodnoty sloupce.

1. Podržte stisknuté tlačítko ALT + F11 klávesy pro otevření Microsoft Visual Basic pro aplikace okno.

2. cvaknutí Vložit > Modula vložte následující kód do Okno modulu.

Sub SplitDataByColToWorkbooks()
    ' Updateby Extendoffice
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer
    Dim xTRg As Range
    Dim xVRg As Range
    Dim xWS As Workbook
    Dim savePath As String
    ' Set the directory to save new workbooks
    savePath = "C:\Users\AddinsVM001\Desktop\multiple files\" ' Modify this path as needed
    Application.DisplayAlerts = False
    Set xTRg = Application.InputBox("Please select the header rows:", "Kutools for Excel", Type:=8)
    If TypeName(xTRg) = "Nothing" Then Exit Sub
    Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Kutools for Excel", Type:=8)
    If TypeName(xVRg) = "Nothing" Then Exit Sub
    vcol = xVRg.Column
    Set ws = xTRg.Worksheet
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = xTRg.Address(False, False)
    titlerow = xTRg.Row
    ws.Columns(vcol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Cells(1, ws.Columns.Count), Unique:=True
    myarr = Application.Transpose(ws.Cells(1, ws.Columns.Count).Resize(ws.Cells(ws.Rows.Count, ws.Columns.Count).End(xlUp).Row).Value)
    ws.Cells(1, ws.Columns.Count).Resize(ws.Cells(ws.Rows.Count, ws.Columns.Count).End(xlUp).Row).ClearContents
    For i = 2 To UBound(myarr)
        Set xWS = Workbooks.Add
        ws.Range(title).AutoFilter Field:=vcol, Criteria1:=myarr(i)
        ws.Range("A" & titlerow & ":A" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Copy
        xWS.Sheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteAll
        xWS.SaveAs Filename:=savePath & myarr(i) & ".xlsx"

        xWS.Close SaveChanges:=False
    Next i
    ws.AutoFilterMode = False
    Application.DisplayAlerts = True
    ws.Activate
End Sub

3. Poté stiskněte F5 pro spuštění kódu a zobrazí se okno s výzvou, které vám připomene vybrat řádek záhlaví a poté klepněte OK. Viz snímek obrazovky:

4. Ve druhém řádku výzvy vyberte data sloupce, podle kterých chcete rozdělit, a poté klepněte OK. Viz snímek obrazovky:

5. Po rozdělení jsou všechna data v aktivním listu rozdělena do více sešitů na základě hodnot sloupců. Všechny rozdělené sešity se uloží do vámi určené složky. Viz snímek obrazovky:

Související články: