VBA split sheet based on a repeating value

F

fogarasia

New Member
Joined
Feb 6, 2023
Messages
18
Office Version
  1. 365
Platform
  1. Windows
Hi All!

I have the table below. Usually, this table contains a few hundred thousand rows (packaging recordings for statistics). I want to split the sheet based on Column B (VarName) in that way when I have a B cell containing the DatiStatistica_targetWeight value and then copy the rows after it to a new sheet until a new DatiStatistica_targetWeight value appears. The code works well when I have small data numbers, but with the huge amount of data, the PC freeze. The PC is a Dell Ryzen 5 chip and 16GB memory. And everything is running on max 51%. Is there possible to reduce the computation need for the code? Or any advice for optimizing this?

Thanks!

The code is:
VBA Code: 
Sub SeparateTableByColumnB()
Application.ScreenUpdating = False

    Dim srcTable As ListObject
    Dim srcRow As Range
    Dim dstWorkbook As Workbook
    Dim dstWorksheet As Worksheet
    Dim dstRow As Long
    Dim dstRowStart As Long
    
    ' Set the source table
    Set srcTable = ActiveSheet.ListObjects("Table1")
    
    ' Loop through each row in the table
    For Each srcRow In srcTable.DataBodyRange.Rows
        ' Check if column B contains "DatiStatistica_TargetWeight"
        If srcRow.Cells(2).Value = "DatiStatistica_TargetWeight" Then
            ' Create a new workbook if one does not already exist
            If dstWorkbook Is Nothing Then
                Set dstWorkbook = Workbooks.Add
            End If
            
            ' Add a new worksheet to the destination workbook
            Set dstWorksheet = dstWorkbook.Worksheets.Add
            
            ' Copy the row to the destination worksheet
            dstRowStart = dstWorksheet.Cells(dstWorksheet.Rows.Count, 1).End(xlUp).Row + 1
            srcRow.Resize(srcRow.Rows.Count, srcRow.Columns.Count).Copy dstWorksheet.Cells(dstRowStart, 1)
            dstRow = dstRowStart + srcRow.Rows.Count - 1
        Else
            ' Copy the row to the current destination worksheet
            If Not dstWorksheet Is Nothing Then
                srcRow.Resize(srcRow.Rows.Count, srcRow.Columns.Count).Copy dstWorksheet.Cells(dstRow + 1, 1)
                dstRow = dstRow + srcRow.Rows.Count
            End If
        End If
    Next srcRow
    
    ' Autofit all columns in the destination worksheet
    dstWorksheet.Columns.AutoFit
Application.ScreenUpdating = True

End Sub




Csomi1.xlsm
ABCDEF
1Forrás.NévVarNameTimeStringVarValueValidityTime_ms
2DatiProduzione0.csvDatiStatistica_TargetWeight20/02/2023 08:1070014,498E+14
3DatiProduzione0.csvRecipes_Recipe{0}_TollMinus20/02/2023 08:103014,498E+14
4DatiProduzione0.csvRecipes_Recipe{0}_TollPlus20/02/2023 08:1010014,498E+14
5DatiProduzione0.csvDatiStatistica_TargetWeight20/02/2023 08:1170014,498E+14
6DatiProduzione0.csvRecipes_Recipe{0}_TollMinus20/02/2023 08:113014,498E+14
7DatiProduzione0.csvRecipes_Recipe{0}_TollPlus20/02/2023 08:1110014,498E+14
8DatiProduzione0.csvDatiStatistica_TargetWeight20/02/2023 08:5770014,498E+14
9DatiProduzione0.csvRecipes_Recipe{0}_TollMinus20/02/2023 08:573014,498E+14
10DatiProduzione0.csvRecipes_Recipe{0}_TollPlus20/02/2023 08:5710014,498E+14
11DatiProduzione0.csvDatiStatistica_TargetWeight20/02/2023 09:3470014,498E+14
12DatiProduzione0.csvRecipes_Recipe{0}_TollMinus20/02/2023 09:343014,498E+14
13DatiProduzione0.csvRecipes_Recipe{0}_TollPlus20/02/2023 09:3410014,498E+14
14DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 09:3570014,498E+14
15DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 09:3570014,498E+14
16DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 09:3570014,498E+14
17DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 09:3569914,498E+14
18DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 09:3568314,498E+14
19DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 09:3570014,498E+13
20DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 09:3570014,498E+14
21DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 09:3570014,498E+14
22DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 09:3570014,498E+14
23DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 09:3570014,498E+14
24DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 09:3569914,498E+14
25DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 09:3569914,498E+14
26DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 09:3570014,498E+14
27DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 09:3570014,498E+14
28DatiProduzione0.csvDatiStatistica_TargetWeight20/02/2023 09:3470014,498E+14
29DatiProduzione0.csvDatiStatistica_TargetWeight20/02/2023 15:27140014,498E+14
30DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 15:27140014,498E+14
31DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 15:27140014,498E+14
32DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 15:27140014,498E+14
33DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 15:27140014,498E+14
34DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 15:27140014,498E+14
35DatiProduzione0.csvDatiStatistica_CombiWeight20/02/2023 15:27140014,498E+14
Sheet1
 

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.
Sort by date Sort by votes
CCTO
forgot where I got it but try to play with the code

Rich (BB code): 
Sub filter()

    Application.ScreenUpdating = False
    Dim x As Range, rng As Range
    Dim last As Long
    Dim sht As String
    
    'specify sheet name in which the data is stored
    sht = "DATA Sheet"
    'change filter column in the following code
    last = Sheets(sht).Cells(Rows.Count, "F").End(xlUp).Row
    Set rng = Sheets(sht).Range("A1:F" & last)
    
    Sheets(sht).Range("F1:F" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
    
    For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
        With rng
            .AutoFilter
            .AutoFilter Field:=6, Criteria1:=x.Value
            .SpecialCells(xlCellTypeVisible).Copy
            
            Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
            ActiveSheet.Paste
        End With
    Next x
    ' Turn off filter
    Sheets(sht).AutoFilterMode = False
    
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With

End Sub

VBA AUto Filter.xlsm
ABCDEFGHAA
1nameageadresscontactorgrankrank
2richa2iiixyzprst11
3shweta6hhhxyzprst22
4garima7jjjxyzprst33
5kalpana8lllxyzprst44
6rekha1kkkxyzprst1
7kareena6uuuxyzprst3
8champa2iiixyzprst4
9chameli6hhhxyzprst2
10ram7jjjxyzprst3
11laxman8lllxyzprst4
12seeta1kkkxyzprst1
13ganesh6uuuxyzprst3
14gautam2iiixyzprst2
15rahul6hhhxyzprst1
16
DATA Sheet
 
Upvote 0
Give this a go:
VBA Code: 
Sub test()
    Dim rng As Range, unq As Variant, x As Long, wb As Workbook, ws As Worksheet
    Dim hVar As Variant, rCount As Long
    
    Set rng = Sheet1.ListObjects("Table1").DataBodyRange
    hVar = Sheet1.Range("A1:F1").Value
    unq = Application.Unique(Application.Index(rng, , 2))
    
    For x = 1 To UBound(unq)
        Set ws = Sheets.Add(, Sheets(Sheets.Count))
        ws.Name = unq(x, 1)
        ws.Range("A1:F1") = hVar
        rCount = Application.CountIf(Sheet1.Range("B:B"), unq(x, 1))
        ws.Range("A2:F" & rCount + 1) = Evaluate("FILTER(Sheet1!A:F,Sheet1!B:B=""" & unq(x, 1) & ""","""")")
        ws.Range("A:F").EntireColumn.AutoFit
    Next x
    
    Sheets(Application.Transpose(unq)).Move
End Sub
 
Upvote 0
Try this.
VBA Code: 
Sub test()
    Application.ScreenUpdating = False
    Dim srcTable As ListObject, huc As Range, rngV As Range, i&, itms
    Set srcTable = ActiveSheet.ListObjects("Table1")

    srcTable.Range.AutoFilter Field:=2, Criteria1:="DatiStatistica_TargetWeight"

    Set rngV = srcTable.Range.Columns(1).SpecialCells(xlCellTypeVisible)
    If rngV.Cells.Count = 1 Then Exit Sub
    Workbooks.Add
    
    With CreateObject("Scripting.Dictionary")
        For Each huc In rngV
            .Item(huc.Row) = huc.Row
        Next huc
        .Remove (1)
        .Item("Last") = srcTable.Range.Rows.Count + 1
        itms = .items
        srcTable.Range.AutoFilter
        For i = 0 To UBound(itms) - 1
            srcTable.Range.Rows(itms(i)).Resize(itms(i + 1) - itms(i)).Copy Worksheets.Add.Range("A1")
            Columns.AutoFit
        Next i
    End With
    
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

F
  • Question Question
VBA Macro Issue: Replacing Simple Formula with Complex Formula Causes Error
Replies
2
Views
126
flashgordie
F
A
  • Question Question
Create report by matching part of item and populate for each cell under item across sheets
Replies
2
Views
217
Ali M
A
V
  • Question Question
Update Record.
Replies
1
Views
452
vmjan02
V
A
  • Solved
Copy data from listbox on userform to listbox and add header for each range
2
Replies
10
Views
141
abdo meghari
A
Kellie220
  • Question Question
VBA to Collapse Rows (3 part question)
Replies
1
Views
283
Artik
Artik

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top