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

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand
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

V
  • Question
Update Record.
Replies
1
Views
313
vmjan02
V
P
  • Question
Look for a Value in Column B and Delete Rows after Comparing Values in Column C
Replies
0
Views
226
Plokimu77
P
K
  • Question
Excel Pivot table Time Values is not populating same as Source Sheet
Replies
1
Views
324
awoohaw
awoohaw
A
  • Solved
Macro getting stuck on average when no data is present
Replies
5
Views
251
amphead
A
L
  • Question
VBA extract
Replies
1
Views
300
duggie33
D

Forum statistics

Threads
1,215,444
Messages
6,124,891
Members
449,194
Latest member
JayEggleton

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