Using VBA to split data into separate sheets while only updating a certain amount of cells on new sheet.

K

kmil13

New Member
Joined
Mar 15, 2023
Messages
8
Office Version
  1. 365
Platform
  1. MacOS
I'm attaching a link to dummy sheet with data. The first worksheet is titled teacher data, that's my main reference sheet. The second worksheet titled A is what the current code that I'm using does. It sorts the sheet into new individual sheets (students) and then copies all of the data for that student (column B) over to the new sheet.



The third worksheet, title B, is what I need it to do. I need it to copy all of the student info over and update the info on those sheets each time I run the macro. However, I want to include the yellow highlighted section on each created sheet, but I don't want that section to update each time. Essentially, I want it to create the individual sheets and update the only the first 12 rows of each sheet (because the data won't ever be more rows that that.) Is it possible to add to this formula to accomplish this or to use a completely different formula?



Thank you for any help with this. I'm still new to excel and try to figure everything out on my own, but this is a little too complex for me. Please let me know if you need more information (if I need to clarify) or anything else. Thanks!



Teacher Data.xltm.zip



This is the current code that I'm using (and it works perfectly to sort and split the data into newly created sheets, but I need to only update certain cells because I need to write data on sheet B in the highlighted area that doesn't get deleted each time the top portion of data (12 rows) updates.



Sub Split_Sht_in_Separate_Shts()



'### 17-03-2019 ###



Const FirstC As String = "A" '1st column



Const LastC As String = "AJ" 'last column



Const sCol As String = "B" '<<< Criteria in Column B



Const shN As String = "Mishler" '<<< Source Sheet



Dim ws As Worksheet, ws1 As Worksheet



Set ws = Sheets(shN)



Dim rng As Range



Dim r As Long, c As Long, x As Long, r1 As Long



Application.ScreenUpdating = False



r = ws.Range(FirstC & ":" & LastC).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row



c = ws.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 2



Set rng = ws.Range(ws.Cells(1, FirstC), ws.Cells(r, LastC))



ws.Range(sCol & ":" & sCol).Copy



ws.Cells(1, c).PasteSpecial xlValues



Application.CutCopyMode = False



ws.Cells(1, c).Resize(r).RemoveDuplicates Columns:=1, Header:=xlYes



r1 = ws.Cells(Rows.Count, c).End(xlUp).Row



ws.Cells(1, c).Resize(r1).Sort Key1:=ws.Cells(1, c), Header:=xlYes



ws.AutoFilterMode = False



Application.DisplayAlerts = False



For x = 2 To r1



For Each ws1 In Sheets



If ws1.Name = ws.Cells(x, c) Then ws1.Delete



Next



Next



Application.DisplayAlerts = True



For x = 2 To r1



ws.Range(ws.Cells(1, sCol), ws.Cells(r, sCol)).AutoFilter Field:=1, Criteria1:=ws.Cells(x, c)



Set ws1 = Worksheets.Add(after:=Worksheets(Worksheets.Count))



ws1.Name = ws.Cells(x, c).Value



rng.SpecialCells(xlCellTypeVisible).Copy



Range("A1").PasteSpecial Paste:=xlPasteFormats



Range("A1").PasteSpecial Paste:=xlPasteColumnWidths



Range("A1").PasteSpecial Paste:=xlPasteValues



Application.CutCopyMode = False



Next x



With ws



.AutoFilterMode = False



.Cells(1, c).Resize(r).ClearContents



.Activate



.Range("A1").Select



End With



Application.ScreenUpdating = True



End Sub
 
Sort by date Sort by votes
sijpie said:
Ah, I see what went wrong here. At the last minute before posting I had renamed your various variables to give them more meaningful names. But I apparently forgot to replace a couple.

Sorry about that. I have also added the line 'Option Explicit' at the very top of the code. That forces declaration of any variables. So unknown / misspelt variable names will be highlighted before the code can run.

Here is the now corrected code. Replace everything with this.

VBA Code: 
Option Explicit

Sub Split_Sht_in_Separate_Shts()

'### 22/03/2023 ###

    Const FirstC As String = "A" '1st column
    Const LastC As String = "AJ" 'last column
    Const sCol As String = "B" '<<< Criteria in Column B
    Const shN As String = "Teacher Data" '<<< Source Sheet
    Const shT As String = "Template"    '<<<<<<<< Template sheet
    Dim wsTData As Worksheet, wsSt As Worksheet, wsT As Worksheet
    Dim rData As Range
    Dim lLastR As Long, lC As Long, lX As Long, lRStN As Long, iTotR As Integer
    Dim bFound As Boolean
    Dim sStName
   
    Set wsTData = Sheets(shN)
    Set wsT = Sheets(shT)
   
    'stop screen flikker for the next section
    Application.ScreenUpdating = False
   
    'get the last row
    lLastR = wsTData.Range(FirstC & ":" & LastC).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    'get  last column +2 to temp store list of unique names
    lC = wsTData.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 2
   
    Set rData = wsTData.Range(wsTData.Cells(1, FirstC), wsTData.Cells(lLastR, LastC))
''    'copy paste is slow
'''    wsTData.Range(sCol & ":" & sCol).Copy
'''    wsTData.Cells(1, c).PasteSpecial xlValues
    'just set the values of the destination range to the value of the origin range
    wsTData.Range(Cells(1, lC), Cells(lLastR, lC)).Value = wsTData.Range(sCol & "1:" & sCol & lLastR).Value
   
'    Application.CutCopyMode = False
   
    wsTData.Cells(1, lC).Resize(lLastR).RemoveDuplicates Columns:=1, Header:=xlYes
    'the line above is very nifty way of getting unique values. Haven't seen that before
   
   
    lRStN = wsTData.Cells(wsTData.Rows.Count, lC).End(xlUp).Row
    wsTData.Cells(1, lC).Resize(lRStN).Sort Key1:=wsTData.Cells(1, lC), Header:=xlYes
    wsTData.AutoFilterMode = False
   
    wsT.Visible = xlSheetVisible
    For lX = 2 To lRStN
        bFound = False
        ' Check the sheets for each student. _
          If one doesn't exist, make a copy of the template sheet. _
          If one does exist, then clear the first 11 rows
        sStName = wsTData.Cells(lX, lC)
        For Each wsSt In Sheets
            If wsSt.Name Like sStName Then
                wsSt.Range("1:11").EntireRow.ClearContents
                bFound = True
                Exit For
            End If
        Next wsSt
        If Not bFound Then      'create new sheet for student
            Sheets("Template").Select
            Sheets("Template").Copy After:=Sheets(Sheets.Count)
            Set wsSt = ActiveSheet
            wsSt.Name = sStName
        End If
       
        ' Now copy the filtered range to the sheet
        wsTData.Range(wsTData.Cells(1, sCol), wsTData.Cells(lLastR, sCol)).AutoFilter Field:=1, Criteria1:=wsTData.Cells(lX, lC)
        ' Check if number of rows less than 11, else create more space
        iTotR = GetRowsinAreas(rData.SpecialCells(xlCellTypeVisible))
        If iTotR > 11 Then
            CreateRows iTotR, wsSt
        End If
        rData.SpecialCells(xlCellTypeVisible).Copy
''        ' If the template has the required formatting and column widths, then no need to do the following
'''        wsSt.Range("A1").PasteSpecial Paste:=xlPasteFormats
'''        wsSt.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
        wsSt.Range("A1").PasteSpecial Paste:=xlPasteValues
    Next lX
    For Each wsSt In Worksheets
        wsSt.Activate
        wsSt.Range("A1").Select
    Next wsSt
    wsT.Visible = xlSheetHidden
   
   
    ' reset the master sheet
    With wsTData
        .AutoFilterMode = False
        .Cells(1, lC).Resize(lLastR).ClearContents
        .Activate
    End With
   
    Application.ScreenUpdating = True

End Sub

Function GetRowsinAreas(rRng As Range) As Long
'This function counts the total rows in a discontiguous range, _
 such as a filtered range.
    Dim iRt As Long, rA As Range
   
    For Each rA In rRng.Areas
   
    iRt = iRt + rA.RowsTData.Count
    Next rA
    GetRowsinAreas = iRt
End Function

Sub CreateRows(iTot As Integer, wsWS As Worksheet)
'In case there are more rows then there is space in the template _
 this sub will create extra rows
    Dim rF As Range
    Const iBOXrow As Integer = 12   ' <<<< Starting row of Box in Template sheet
   
    Set rF = wswsTData.UsedRange.Find("Dyslexia")
    If Not rF Is Nothing Then
        Select Case rF.Row
            Case iBOXrow        'default row in template
                'only add rows
                wswsTData.Cells(3).Resize(iTot - iBOXrow + 1, 1).EntireRow.Insert
            Case Is > iBOXrow   'there are already more rows than 11. Clear these first
                wswsTData.Range("11:" & iTot - 1).EntireRow.ClearContents
               
        End Select
    End If
End Sub
Click to expand...
Actually, I deleted the entire module and created a new one. Hit the copy button on the code you listed as new. Then pasted it there. Now it's throwing a different code. Is it always this difficult or am I just asking for something outrageous?

wsTData.Range(Cells(1, lC), Cells(lLastR, lC)).Value = wsTData.Range(sCol & "1:" & sCol & lLastR).Value
 
Upvote 0

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.
I should have checked first. I did a replace all somewhere and never checked properly. I have now run the code below, and it works well with both existing and new to be created student sheets

VBA Code: 
Option Explicit

Sub Split_Sht_in_Separate_Shts()

'### 29/03/2023 ###

    Const FirstC As String = "A" '1st column
    Const LastC As String = "AJ" 'last column
    Const sCol As String = "B" '<<< Criteria in Column B
    Const shN As String = "Teacher Data" '<<< Source Sheet
    Const shT As String = "Template"    '<<<<<<<< Template sheet
    Dim wsTData As Worksheet, wsSt As Worksheet, wsT As Worksheet
    Dim rData As Range
    Dim lLastR As Long, lC As Long, lX As Long, lRStN As Long, iTotR As Integer
    Dim bFound As Boolean
    Dim sStName
    
    Set wsTData = Sheets(shN)
    Set wsT = Sheets(shT)
    
    'stop screen flikker for the next section
    Application.ScreenUpdating = False
    
    'get the last row
    lLastR = wsTData.Range(FirstC & ":" & LastC).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    'get  last column +2 to temp store list of unique names
    lC = wsTData.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 2
    
    Set rData = wsTData.Range(wsTData.Cells(1, FirstC), wsTData.Cells(lLastR, LastC))
    'just set the values of the destination range to the value of the origin range
    wsTData.Range(Cells(1, lC), Cells(lLastR, lC)).Value = wsTData.Range(sCol & "1:" & sCol & lLastR).Value
    
'    Application.CutCopyMode = False
    
    wsTData.Cells(1, lC).Resize(lLastR).RemoveDuplicates Columns:=1, Header:=xlYes
    'the line above is very nifty way of getting unique values. Haven't seen that before
    
    
    lRStN = wsTData.Cells(wsTData.Rows.Count, lC).End(xlUp).Row
    wsTData.Cells(1, lC).Resize(lRStN).Sort Key1:=wsTData.Cells(1, lC), Header:=xlYes
    wsTData.AutoFilterMode = False
    
    wsT.Visible = xlSheetVisible
    For lX = 2 To lRStN
        bFound = False
        ' Check the sheets for each student. _
          If one doesn't exist, make a copy of the template sheet. _
          If one does exist, then clear the first 11 rows
        sStName = wsTData.Cells(lX, lC)
        For Each wsSt In Sheets
            If wsSt.Name Like sStName Then
                wsSt.Range("1:11").EntireRow.ClearContents
                bFound = True
                Exit For
            End If
        Next wsSt
        If Not bFound Then      'create new sheet for student
            Sheets("Template").Select
            Sheets("Template").Copy After:=Sheets(Sheets.Count)
            Set wsSt = ActiveSheet
            wsSt.Name = sStName
        End If
        
        ' Now copy the filtered range to the sheet
        wsTData.Range(wsTData.Cells(1, sCol), wsTData.Cells(lLastR, sCol)).AutoFilter Field:=1, Criteria1:=wsTData.Cells(lX, lC)
        ' Check if number of rows less than 11, else create more space
        iTotR = GetRowsinAreas(rData.SpecialCells(xlCellTypeVisible))
        If iTotR > 11 Then
            CreateRows iTotR, wsSt
        End If
        rData.SpecialCells(xlCellTypeVisible).Copy
        wsSt.Range("A1").PasteSpecial Paste:=xlPasteValues
    Next lX
    For Each wsSt In Worksheets
        wsSt.Activate
        wsSt.Range("A1").Select
    Next wsSt
    wsT.Visible = xlSheetHidden
    
    
    ' reset the master sheet
    With wsTData
        .AutoFilterMode = False
        .Cells(1, lC).Resize(lLastR).ClearContents
        .Activate
    End With
    
    Application.ScreenUpdating = True

End Sub

Function GetRowsinAreas(rRng As Range) As Long
'This function counts the total rows in a discontiguous range, _
 such as a filtered range.
    Dim iRt As Long, rA As Range
    
    For Each rA In rRng.Areas
    
    iRt = iRt + rA.Rows.Count
    Next rA
    GetRowsinAreas = iRt
End Function

Sub CreateRows(iTot As Integer, wsWS As Worksheet)
'In case there are more rows then there is space in the template _
 this sub will create extra rows
    Dim rF As Range
    Const iBOXrow As Integer = 12   ' <<<< Starting row of Box in Template sheet
    
    Set rF = wsWS.UsedRange.Find("Dyslexia")
    If Not rF Is Nothing Then
        Select Case rF.Row
            Case iBOXrow        'default row in template
                'only add rows
                wsWS.Cells(3).Resize(iTot - iBOXrow + 1, 1).EntireRow.Insert
            Case Is > iBOXrow   'there are already more rows than 11. Clear these first
                wsWS.Range("11:" & iTot - 1).EntireRow.ClearContents
                
        End Select
    End If
End Sub

I don't understand why you see a bug in the line you just highlighted, it worked fine before...

No, coding is not always difficult. But as you notice, bugs creep up if one is not careful with the details...
 
Upvote 1
Solution
sijpie said:
I should have checked first. I did a replace all somewhere and never checked properly. I have now run the code below, and it works well with both existing and new to be created student sheets

VBA Code: 
Option Explicit

Sub Split_Sht_in_Separate_Shts()

'### 29/03/2023 ###

    Const FirstC As String = "A" '1st column
    Const LastC As String = "AJ" 'last column
    Const sCol As String = "B" '<<< Criteria in Column B
    Const shN As String = "Teacher Data" '<<< Source Sheet
    Const shT As String = "Template"    '<<<<<<<< Template sheet
    Dim wsTData As Worksheet, wsSt As Worksheet, wsT As Worksheet
    Dim rData As Range
    Dim lLastR As Long, lC As Long, lX As Long, lRStN As Long, iTotR As Integer
    Dim bFound As Boolean
    Dim sStName
   
    Set wsTData = Sheets(shN)
    Set wsT = Sheets(shT)
   
    'stop screen flikker for the next section
    Application.ScreenUpdating = False
   
    'get the last row
    lLastR = wsTData.Range(FirstC & ":" & LastC).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    'get  last column +2 to temp store list of unique names
    lC = wsTData.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 2
   
    Set rData = wsTData.Range(wsTData.Cells(1, FirstC), wsTData.Cells(lLastR, LastC))
    'just set the values of the destination range to the value of the origin range
    wsTData.Range(Cells(1, lC), Cells(lLastR, lC)).Value = wsTData.Range(sCol & "1:" & sCol & lLastR).Value
   
'    Application.CutCopyMode = False
   
    wsTData.Cells(1, lC).Resize(lLastR).RemoveDuplicates Columns:=1, Header:=xlYes
    'the line above is very nifty way of getting unique values. Haven't seen that before
   
   
    lRStN = wsTData.Cells(wsTData.Rows.Count, lC).End(xlUp).Row
    wsTData.Cells(1, lC).Resize(lRStN).Sort Key1:=wsTData.Cells(1, lC), Header:=xlYes
    wsTData.AutoFilterMode = False
   
    wsT.Visible = xlSheetVisible
    For lX = 2 To lRStN
        bFound = False
        ' Check the sheets for each student. _
          If one doesn't exist, make a copy of the template sheet. _
          If one does exist, then clear the first 11 rows
        sStName = wsTData.Cells(lX, lC)
        For Each wsSt In Sheets
            If wsSt.Name Like sStName Then
                wsSt.Range("1:11").EntireRow.ClearContents
                bFound = True
                Exit For
            End If
        Next wsSt
        If Not bFound Then      'create new sheet for student
            Sheets("Template").Select
            Sheets("Template").Copy After:=Sheets(Sheets.Count)
            Set wsSt = ActiveSheet
            wsSt.Name = sStName
        End If
       
        ' Now copy the filtered range to the sheet
        wsTData.Range(wsTData.Cells(1, sCol), wsTData.Cells(lLastR, sCol)).AutoFilter Field:=1, Criteria1:=wsTData.Cells(lX, lC)
        ' Check if number of rows less than 11, else create more space
        iTotR = GetRowsinAreas(rData.SpecialCells(xlCellTypeVisible))
        If iTotR > 11 Then
            CreateRows iTotR, wsSt
        End If
        rData.SpecialCells(xlCellTypeVisible).Copy
        wsSt.Range("A1").PasteSpecial Paste:=xlPasteValues
    Next lX
    For Each wsSt In Worksheets
        wsSt.Activate
        wsSt.Range("A1").Select
    Next wsSt
    wsT.Visible = xlSheetHidden
   
   
    ' reset the master sheet
    With wsTData
        .AutoFilterMode = False
        .Cells(1, lC).Resize(lLastR).ClearContents
        .Activate
    End With
   
    Application.ScreenUpdating = True

End Sub

Function GetRowsinAreas(rRng As Range) As Long
'This function counts the total rows in a discontiguous range, _
 such as a filtered range.
    Dim iRt As Long, rA As Range
   
    For Each rA In rRng.Areas
   
    iRt = iRt + rA.Rows.Count
    Next rA
    GetRowsinAreas = iRt
End Function

Sub CreateRows(iTot As Integer, wsWS As Worksheet)
'In case there are more rows then there is space in the template _
 this sub will create extra rows
    Dim rF As Range
    Const iBOXrow As Integer = 12   ' <<<< Starting row of Box in Template sheet
   
    Set rF = wsWS.UsedRange.Find("Dyslexia")
    If Not rF Is Nothing Then
        Select Case rF.Row
            Case iBOXrow        'default row in template
                'only add rows
                wsWS.Cells(3).Resize(iTot - iBOXrow + 1, 1).EntireRow.Insert
            Case Is > iBOXrow   'there are already more rows than 11. Clear these first
                wsWS.Range("11:" & iTot - 1).EntireRow.ClearContents
               
        End Select
    End If
End Sub

I don't understand why you see a bug in the line you just highlighted, it worked fine before...

No, coding is not always difficult. But as you notice, bugs creep up if one is not careful with the details...
Click to expand...
Thank you so much! I am beyond grateful for you working this out for me. I'm a reading specialist and have to keep data that is updated each month for 600 kids. This is going to make my workload so much easier in the coming school year.
 
Upvote 0
sijpie said:
I should have checked first. I did a replace all somewhere and never checked properly. I have now run the code below, and it works well with both existing and new to be created student sheets

VBA Code: 
Option Explicit

Sub Split_Sht_in_Separate_Shts()

'### 29/03/2023 ###

    Const FirstC As String = "A" '1st column
    Const LastC As String = "AJ" 'last column
    Const sCol As String = "B" '<<< Criteria in Column B
    Const shN As String = "Teacher Data" '<<< Source Sheet
    Const shT As String = "Template"    '<<<<<<<< Template sheet
    Dim wsTData As Worksheet, wsSt As Worksheet, wsT As Worksheet
    Dim rData As Range
    Dim lLastR As Long, lC As Long, lX As Long, lRStN As Long, iTotR As Integer
    Dim bFound As Boolean
    Dim sStName
  
    Set wsTData = Sheets(shN)
    Set wsT = Sheets(shT)
  
    'stop screen flikker for the next section
    Application.ScreenUpdating = False
  
    'get the last row
    lLastR = wsTData.Range(FirstC & ":" & LastC).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    'get  last column +2 to temp store list of unique names
    lC = wsTData.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 2
  
    Set rData = wsTData.Range(wsTData.Cells(1, FirstC), wsTData.Cells(lLastR, LastC))
    'just set the values of the destination range to the value of the origin range
    wsTData.Range(Cells(1, lC), Cells(lLastR, lC)).Value = wsTData.Range(sCol & "1:" & sCol & lLastR).Value
  
'    Application.CutCopyMode = False
  
    wsTData.Cells(1, lC).Resize(lLastR).RemoveDuplicates Columns:=1, Header:=xlYes
    'the line above is very nifty way of getting unique values. Haven't seen that before
  
  
    lRStN = wsTData.Cells(wsTData.Rows.Count, lC).End(xlUp).Row
    wsTData.Cells(1, lC).Resize(lRStN).Sort Key1:=wsTData.Cells(1, lC), Header:=xlYes
    wsTData.AutoFilterMode = False
  
    wsT.Visible = xlSheetVisible
    For lX = 2 To lRStN
        bFound = False
        ' Check the sheets for each student. _
          If one doesn't exist, make a copy of the template sheet. _
          If one does exist, then clear the first 11 rows
        sStName = wsTData.Cells(lX, lC)
        For Each wsSt In Sheets
            If wsSt.Name Like sStName Then
                wsSt.Range("1:11").EntireRow.ClearContents
                bFound = True
                Exit For
            End If
        Next wsSt
        If Not bFound Then      'create new sheet for student
            Sheets("Template").Select
            Sheets("Template").Copy After:=Sheets(Sheets.Count)
            Set wsSt = ActiveSheet
            wsSt.Name = sStName
        End If
      
        ' Now copy the filtered range to the sheet
        wsTData.Range(wsTData.Cells(1, sCol), wsTData.Cells(lLastR, sCol)).AutoFilter Field:=1, Criteria1:=wsTData.Cells(lX, lC)
        ' Check if number of rows less than 11, else create more space
        iTotR = GetRowsinAreas(rData.SpecialCells(xlCellTypeVisible))
        If iTotR > 11 Then
            CreateRows iTotR, wsSt
        End If
        rData.SpecialCells(xlCellTypeVisible).Copy
        wsSt.Range("A1").PasteSpecial Paste:=xlPasteValues
    Next lX
    For Each wsSt In Worksheets
        wsSt.Activate
        wsSt.Range("A1").Select
    Next wsSt
    wsT.Visible = xlSheetHidden
  
  
    ' reset the master sheet
    With wsTData
        .AutoFilterMode = False
        .Cells(1, lC).Resize(lLastR).ClearContents
        .Activate
    End With
  
    Application.ScreenUpdating = True

End Sub

Function GetRowsinAreas(rRng As Range) As Long
'This function counts the total rows in a discontiguous range, _
 such as a filtered range.
    Dim iRt As Long, rA As Range
  
    For Each rA In rRng.Areas
  
    iRt = iRt + rA.Rows.Count
    Next rA
    GetRowsinAreas = iRt
End Function

Sub CreateRows(iTot As Integer, wsWS As Worksheet)
'In case there are more rows then there is space in the template _
 this sub will create extra rows
    Dim rF As Range
    Const iBOXrow As Integer = 12   ' <<<< Starting row of Box in Template sheet
  
    Set rF = wsWS.UsedRange.Find("Dyslexia")
    If Not rF Is Nothing Then
        Select Case rF.Row
            Case iBOXrow        'default row in template
                'only add rows
                wsWS.Cells(3).Resize(iTot - iBOXrow + 1, 1).EntireRow.Insert
            Case Is > iBOXrow   'there are already more rows than 11. Clear these first
                wsWS.Range("11:" & iTot - 1).EntireRow.ClearContents
              
        End Select
    End If
End Sub

I don't understand why you see a bug in the line you just highlighted, it worked fine before...

No, coding is not always difficult. But as you notice, bugs creep up if one is not careful with the details...
Click to expand...
One last question, if I run this each month, as I add new data to the source sheet, is it going to run into issues? I tried running it twice after I updated the formatting on the template sheet, and it turns my date column into some strange string of numbers that isn't related at all.
 
Last edited:
Upvote 0
It should keep the date formatting. Anyway, I have added one line to reset the date format for column F
Check the comments, towards the end there is a new comment with '<<<< in front. If you want a different format, like American then change as instructed.

VBA Code: 
Option Explicit

Sub Split_Sht_in_Separate_Shts()

'### 29/03/2023 ###

    Const FirstC As String = "A" '1st column
    Const LastC As String = "AJ" 'last column
    Const sCol As String = "B" '<<< Criteria in Column B
    Const shN As String = "Teacher Data" '<<< Source Sheet
    Const shT As String = "Template"    '<<<<<<<< Template sheet
    Dim wsTData As Worksheet, wsSt As Worksheet, wsT As Worksheet
    Dim rData As Range
    Dim lLastR As Long, lC As Long, lX As Long, lRStN As Long, iTotR As Integer
    Dim bFound As Boolean
    Dim sStName
    
    Set wsTData = Sheets(shN)
    Set wsT = Sheets(shT)
    
    'stop screen flikker for the next section
    Application.ScreenUpdating = False
    
    'get the last row
    lLastR = wsTData.Range(FirstC & ":" & LastC).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    'get  last column +2 to temp store list of unique names
    lC = wsTData.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 2
    
    Set rData = wsTData.Range(wsTData.Cells(1, FirstC), wsTData.Cells(lLastR, LastC))
    'just set the values of the destination range to the value of the origin range
    wsTData.Range(Cells(1, lC), Cells(lLastR, lC)).Value = wsTData.Range(sCol & "1:" & sCol & lLastR).Value
    
'    Application.CutCopyMode = False
    
    wsTData.Cells(1, lC).Resize(lLastR).RemoveDuplicates Columns:=1, Header:=xlYes
    'the line above is very nifty way of getting unique values. Haven't seen that before
    
    
    lRStN = wsTData.Cells(wsTData.Rows.Count, lC).End(xlUp).Row
    wsTData.Cells(1, lC).Resize(lRStN).Sort Key1:=wsTData.Cells(1, lC), Header:=xlYes
    wsTData.AutoFilterMode = False
    
    wsT.Visible = xlSheetVisible
    For lX = 2 To lRStN
        bFound = False
        ' Check the sheets for each student. _
          If one doesn't exist, make a copy of the template sheet. _
          If one does exist, then clear the first 11 rows
        sStName = wsTData.Cells(lX, lC)
        For Each wsSt In Sheets
            If wsSt.Name Like sStName Then
                wsSt.Range("1:11").EntireRow.ClearContents
                bFound = True
                Exit For
            End If
        Next wsSt
        If Not bFound Then      'create new sheet for student
            Sheets("Template").Select
            Sheets("Template").Copy After:=Sheets(Sheets.Count)
            Set wsSt = ActiveSheet
            wsSt.Name = sStName
        End If
        
        ' Now copy the filtered range to the sheet
        wsTData.Range(wsTData.Cells(1, sCol), wsTData.Cells(lLastR, sCol)).AutoFilter Field:=1, Criteria1:=wsTData.Cells(lX, lC)
        ' Check if number of rows less than 11, else create more space
        iTotR = GetRowsinAreas(rData.SpecialCells(xlCellTypeVisible))
        If iTotR > 11 Then
            CreateRows iTotR, wsSt
        End If
        rData.SpecialCells(xlCellTypeVisible).Copy
        wsSt.Range("A1").PasteSpecial Paste:=xlPasteValues
        wsSt.Range("F1").Resize(iTotR, 1).NumberFormat = "dd/mm/yyyy" '<<<< change this to "mm/dd/yyyy" for american date notation
    Next lX
    For Each wsSt In Worksheets
        wsSt.Activate
        wsSt.Range("A1").Select
    Next wsSt
    wsT.Visible = xlSheetHidden
    
    
    ' reset the master sheet
    With wsTData
        .AutoFilterMode = False
        .Cells(1, lC).Resize(lLastR).ClearContents
        .Activate
    End With
    
    Application.ScreenUpdating = True

End Sub

Function GetRowsinAreas(rRng As Range) As Long
'This function counts the total rows in a discontiguous range, _
 such as a filtered range.
    Dim iRt As Long, rA As Range
    
    For Each rA In rRng.Areas
    
    iRt = iRt + rA.Rows.Count
    Next rA
    GetRowsinAreas = iRt
End Function

Sub CreateRows(iTot As Integer, wsWS As Worksheet)
'In case there are more rows then there is space in the template _
 this sub will create extra rows
    Dim rF As Range
    Const iBOXrow As Integer = 12   ' <<<< Starting row of Box in Template sheet
    
    Set rF = wsWS.UsedRange.Find("Dyslexia")
    If Not rF Is Nothing Then
        Select Case rF.Row
            Case iBOXrow        'default row in template
                'only add rows
                wsWS.Cells(3).Resize(iTot - iBOXrow + 1, 1).EntireRow.Insert
            Case Is > iBOXrow   'there are already more rows than 11. Clear these first
                wsWS.Range("11:" & iTot - 1).EntireRow.ClearContents
                
        End Select
    End If
End Sub

By the way, dates are just numbers. 1 = 1st Jan 1900. 2= 2 Jan 1900, and so on. And so 44986 = 1 March 2023
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
I need to rename a Sheet
Replies
1
Views
351
CSmith
CSmith
J
  • Solved
Sheet Names to long when creating New worksheet
Replies
3
Views
377
mumps
mumps
J
  • Question
Naming Worksheets based on column values.
Replies
1
Views
586
Alex Blakenburg
A
S
  • Question
Parse data - Overwrite lines with updated data
Replies
0
Views
123
Scifo
S
F
  • Question
Excel VBA - Split Sheets of Saved excel Files
Replies
2
Views
769
Fluff
Fluff

Forum statistics

Threads
1,214,987
Messages
6,122,614
Members
449,091
Latest member
gaurav_7829

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