Split data in sheets (sheets typically already created)

[jamescooper]

So I have data in the sheet - sheet name = "data"
The data has headers in row 1, A1:I1
I would like to cut and paste each row based on the value in column I.
The values in column I are in date format: yyyymmdd e.g. 20220618
The sheets have already been created so do not need creating (the VBA code could check though if it is there first).

Is there a code I can adapt please?

Many thanks.

 

[HighAndWilder]

This should give you what you want.

If you want the worksheet names in date order then sort the 'data' worksheet by column I.

Public Sub subSplitData()
Dim WsSource As Worksheet
Dim Ws As Worksheet
Dim rngData As Range
Dim i As Integer
Dim strWorksheet As String
Dim lngNextRow As Long
Dim rng As Range
Dim rngNames As Range
Dim intColumns As Integer
Dim strWorksheets As String
Dim WsExisting As Worksheet
Dim arrWorksheets() As String
Dim strMsg As String

    ActiveWorkbook.Save

    Set WsSource = Worksheets("Data")

    ' Set range for the new worksheet names.
    Set rngNames = WsSource.Range("A1").CurrentRegion.Offset(1, 0).Resize(Worksheets("Data").Range("A1").CurrentRegion.Rows.Count - 1, _
        Worksheets("Data").Range("A1").CurrentRegion.Columns.Count).Columns(9)
    
    strWorksheets = fncGetWorksheetList(rngNames)
    
    If MsgBox("Delete all sheets and start from scratch.", vbYesNo, "Question") = vbYes Then
        
        Call subDeleteWorksheets(strWorksheets)
        
    Else
            
        If strWorksheets <> "" Then
        
            strMsg = "Some worksheets already exist, do you want to delete the data from these?"
            
            If MsgBox(strMsg, vbYesNo, "Question") = vbYes Then
                Call subDeleteData(strWorksheets)
            End If
        
        End If
   
    End If

    ' Set range for just the data to be copied.
    Set rngData = WsSource.Range("A1").CurrentRegion.Resize(Worksheets("Data").Range("A1").CurrentRegion.Rows.Count, _
        Worksheets("Data").Range("A1").CurrentRegion.Columns.Count - 1)
        
    ' Loop through each row and copy data to appropriate sheet.
    For Each rng In rngNames.Cells
      
        strWorksheet = rng.Value
        
        ' If the sheet does not exist then create it.
        If Not fncDoesWorksheetExist(ActiveWorkbook, strWorksheet) Then
            
            Set Ws = Worksheets.Add(After:=Sheets(Sheets.Count))
            
            Ws.Name = strWorksheet
            
            ' Copy headers from 'Data' to the new sheet.
            Ws.Range("A1:H1").Value = WsSource.Range("A1:H1").Value
                    
        Else
           
            ' If it does exist then just set a worksheet object.
            Set Ws = Worksheets(strWorksheet)
                
        End If
        
        ' Compile a string containing a unique list of target sheet names.
        If InStr(1, strWorksheets, Ws.Name, vbTextCompare) = 0 Then
            strWorksheets = strWorksheets & " " & Ws.Name
        End If
        
        ' Get the next row in the target sheet.
        lngNextRow = Ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
        
        ' Copy data to target sheet.
        Ws.Range("A" & lngNextRow & ":H" & lngNextRow).Value = WsSource.Range("A" & rng.Row & ":H" & rng.Row).Value
    
    Next rng
        
    arrWorksheets = Split(strWorksheets, " ")
    
    ' Loop through all sheets and format.
    ' Font, size and headers background colour can be changed.
    For i = 1 To UBound(arrWorksheets)
      
        Set Ws = Worksheets(arrWorksheets(i))
        
        With Ws.Range("A1").CurrentRegion
            
            ' Get RGB values from https://wbcci.net/color/
            .Rows(1).Interior.Color = RGB(217, 217, 217)
            .Rows(1).Font.Bold = True
            .Font.Name = "Arial"
            .Font.Size = 14
            .EntireColumn.AutoFit
            
            With .Borders
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = vbBlack
            End With
        
        End With
            
    Next i
    
    MsgBox "Processing Complete.", vbInformation, "Confirmation"
     
End Sub

Private Sub subDeleteData(strWorksheets As String)
Dim arrWorksheets() As String
Dim i As Integer

    arrWorksheets = Split(strWorksheets, " ")
    
    For i = 1 To UBound(arrWorksheets)
    
    Worksheets(arrWorksheets(i)).Activate
    
        Worksheets(arrWorksheets(i)).Range("A1").CurrentRegion.Offset(1, 0).EntireRow.Delete
    
    Next i

End Sub

Private Function fncGetWorksheetList(rngNames As Range) As String
Dim strWorksheets As String
Dim Ws As Worksheet
Dim rng As Range

    ' Compile a string containing a unique list of target sheet names.
    For Each rng In rngNames.Cells
        
        If fncDoesWorksheetExist(ActiveWorkbook, rng.Value) Then
            
            If InStr(1, strWorksheets, rng.Value, vbTextCompare) = 0 Then
                strWorksheets = strWorksheets & " " & rng.Value
            End If
    
        End If
        
    Next rng
    
    fncGetWorksheetList = strWorksheets

End Function

Private Function fncDoesWorksheetExist(Wb As Workbook, strWorksheetName As String) As Boolean
Dim Ws As Worksheet

    For Each Ws In Wb.Worksheets
    
        If Ws.Name = strWorksheetName Then
            fncDoesWorksheetExist = True
            Exit Function
        End If
    
    Next Ws

End Function

Private Sub subDeleteWorksheets(strWorksheets As String)
Dim Ws As Worksheet
Dim Wb As Workbook
Dim arrWorksheets() As String
Dim i As Integer

    Application.DisplayAlerts = False
    
    arrWorksheets = Split(strWorksheets, " ")
    
    For i = 1 To UBound(arrWorksheets)
        Worksheets(arrWorksheets(i)).Delete
    Next i
    
    Application.DisplayAlerts = True

End Sub

 

[DanteAmor]

Here is another macro for you to consider:

Sub create_worksheets()
  Dim c As Range, sh As Worksheet, ky As Variant
  Set sh = Sheets("data")
  With CreateObject("scripting.dictionary")
    For Each c In sh.Range("I2", sh.Range("I" & Rows.Count).End(3))
      If c.Value <> "" Then .Item(c.Value) = Empty
    Next c
    For Each ky In .Keys
      sh.Range("A1:I1").AutoFilter Columns("I").Column, ky
      If Evaluate("ISREF('" & ky & "'!A1)") = False Then
        Sheets.Add(, Sheets(Sheets.Count)).Name = ky
      End If
      sh.AutoFilter.Range.Copy Sheets(CStr(ky)).Range("A" & Sheets(CStr(ky)).Range("I" & Rows.Count).End(3).Row + 1)
    Next ky
  End With
  sh.Select
  sh.ShowAllData
End Sub