Dynamic sheet creation based on unique column entries

[Ana Luna]

Dear all,
I am trying to create as many Excel sheets as there are different values in the Prov column. Each of these sheets will be named according to the Prov number. The corresponding values should be transferred to each sheet. In other words, the values for Prov=1 will go to a sheet named 1_Prov, the values for Prov=2 will go to a sheet named 2_Prov, the values for Prov=3 will go to a sheet named 3_Prov, and the values for Prov=4 will go to a sheet named 4_Prov.

I have the code below, but it only creates the first sheet. Does anyone know how I can achieve my objective?
Thanks in advance.
Please find attached the xlsm file.
Regards

Sub Update()
Dim sDescError As String
Dim wsMaster As Worksheet
Dim wb As Workbook
Dim rngDatos As Range
Dim buRange As Range
Dim buCell As Range
Dim dictBU As Object
Dim lastRow As Long
Dim sheetName As String
Dim buName As Variant
Dim wsBU As Worksheet
Dim visibleRange As Range
Dim cellValue As String

' Confirm the existence of the "Master" sheet
Set wb = ThisWorkbook
On Error Resume Next
Set wsMaster = wb.Sheets("Master")
On Error GoTo 0

If wsMaster Is Nothing Then
Debug.Print "The 'Master' sheet does not exist. Please verify the sheet name."
Exit Sub
End If

' Get the data range in the "Master" sheet
With wsMaster
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rngDatos = .Range("A1:F" & lastRow)
End With

' Create a dictionary to store the different Prov values and avoid duplicates
Set dictBU = CreateObject("Scripting.Dictionary")
Set buRange = wsMaster.Range("A2:A" & lastRow) ' Range that contains the Provs in column A

' Loop through the Prov values and add each one to the dictionary if it does not already exist
For Each buCell In buRange
buName = Trim(CStr(buCell.Value))
If Not dictBU.exists(buName) And buName <> "" Then
dictBU.Add buName, buName
Debug.Print "Prov found and added to the dictionary: " & buName
End If
Next buCell

' Create as many sheets as there are Provs and copy the corresponding data.
For Each buName In dictBU.Keys
' Check if the sheet already exists, and if not, create it
On Error Resume Next
Set wsBU = wb.Sheets(buName & "_Prov")
On Error GoTo 0

If wsBU Is Nothing Then
Set wsBU = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)) ' Create a new sheet
wsBU.Name = buName & "_Prov"
Debug.Print "Created a new sheet: " & wsBU.Name
Else
' Clear the sheet before copying new data
wsBU.Cells.Clear
End If

' Copy the headers from the "Master" sheet to the new sheet
wsMaster.Rows(1).Copy Destination:=wsBU.Rows(1)

' *** IMPORTANT *** Remove any existing filters before applying a new one
If wsMaster.AutoFilterMode Then
wsMaster.AutoFilterMode = False
Debug.Print "Filter removed from the 'Master' sheet before applying a new one."
End If

' Filter the Prov data and copy it to the new sheet
With rngDatos
.AutoFilter Field:=1, Criteria1:=buName ' Filter by Prov (Field 1 = Column A)

' Check if there are visible rows after filtering
On Error Resume Next
Set visibleRange = .SpecialCells(xlCellTypeVisible) ' Get the visible range after applying the filter
On Error GoTo 0

' Verify that the visible range is not null and has more than one row (header + data)
If Not visibleRange Is Nothing Then
If visibleRange.Areas(1).Rows.Count > 1 Then
' Paste data into the new sheet starting from the second row
visibleRange.Copy Destination:=wsBU.Rows(2)
Debug.Print "Data copied to sheet: " & wsBU.Name
Else
Debug.Print "No visible data for Prov: " & buName
End If
Else
Debug.Print "Visible range is Nothing for Prov: " & buName
End If

' Remove the filter after each operation
If wsMaster.AutoFilterMode Then
.AutoFilter ' Remove the applied filter
Debug.Print "Filter removed after copying the data for Prov: " & buName
End If
End With

' Adjust the column widths in the created sheet
wsBU.Columns.AutoFit
Next buName

' Success message
Debug.Print "Sheets corresponding to each Prov have been successfully created and filled."

End Sub

 

[Marc L]

Hola, according to your attachment an Excel basics VBA demonstration to paste only to Sheet1 (Master) worksheet module :​

Sub Demo1()
        Dim R&
   With Parent.Worksheets
    If .Count > Index Then
        Application.DisplayAlerts = False
       .Item(Evaluate("TRANSPOSE(ROW(" & Index + 1 & ":" & .Count & "))")).Delete
        Application.DisplayAlerts = True
    End If
        [A1].CurrentRegion.Columns(1).AdvancedFilter 2, , [Z1], True
        [Z1].CurrentRegion.Sort [Z1], 2, Header:=1
    For R = 2 To [Z1].CurrentRegion.Count
        [Z2] = Cells(R, 26)
       .Add(, Me).Name = [Z2&"_Prov"]
        [A1].CurrentRegion.AdvancedFilter 2, [Z1:Z2], ActiveSheet.[A1]
    Next
   End With
        [Z1].CurrentRegion.Clear
End Sub

Do you like it ? So thanks to click on bottom right Like !​

​