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
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
Sort by date Sort by votes
Hi kmil, welcome to the board.

Please next time you post any vba code, put it between code brackets: click the little VBA icon at the top of the post window and paste your code.

I have gone through your code to get rid of some inefficiencies. See the double commented out pieces.

Then I have modified the code to do what you want to achieve. I have even added in some code to make sure the fixed block does not get overwritten in the odd case that the filter does return more than eleven lines for the student.

What you need to do is from your current sheet B create a template by making sure the first 11 lines have the correct formatting & conditional formatting. Then save the sheet with the name Template
Then test the code below on the workbook. It will hide the sheet Template once finished.

VBA Code: 
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(RowsTData.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(shT).Select
            Sheets(shT).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, c)
        ' 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 ws
        .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
 
Upvote 0
sijpie said:
Hi kmil, welcome to the board.

Please next time you post any vba code, put it between code brackets: click the little VBA icon at the top of the post window and paste your code.

I have gone through your code to get rid of some inefficiencies. See the double commented out pieces.

Then I have modified the code to do what you want to achieve. I have even added in some code to make sure the fixed block does not get overwritten in the odd case that the filter does return more than eleven lines for the student.

What you need to do is from your current sheet B create a template by making sure the first 11 lines have the correct formatting & conditional formatting. Then save the sheet with the name Template
Then test the code below on the workbook. It will hide the sheet Template once finished.

VBA Code: 
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(RowsTData.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(shT).Select
            Sheets(shT).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, c)
        ' 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 ws
        .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...
I'm pretty sure I'm in well over my head and will have to figure out a different method/program to use for what I'm trying to accomplish. I created the template sheet within the workbook, but when I ran the code, I got a "run-time 1004. Method 'range' of object '_worksheet' failed. Thank you for trying to help though. I was really hoping that this would solve my problem.
 
Upvote 0
It should work. I'll get back with some more elaborated instructions
 
Upvote 0
When you run the code, and it stops with the error. Press on the 'Debug' button. It will open the VBA editor and show a line in yellow. Which line is it that is yellow?

What you should have at the start is:
  • the master data sheet
  • a template sheet with 11 empty lines (with conditional formatting) On row 12 the information block starts. Also in row 12 there is a cell with the word "Dyslexia".
  • Possibly some filled out student sheets, also containing the info block.
 
Upvote 0
sijpie said:
When you run the code, and it stops with the error. Press on the 'Debug' button. It will open the VBA editor and show a line in yellow. Which line is it that is yellow?

What you should have at the start is:
  • the master data sheet
  • a template sheet with 11 empty lines (with conditional formatting) On row 12 the information block starts. Also in row 12 there is a cell with the word "Dyslexia".
  • Possibly some filled out student sheets, also containing the info block.
Click to expand...
For some reason, I'm just now seeing this and didn't receive a notification. Sorry.

I have the master date sheet labeled "Teacher Data". I have a template sheet with conditional formatting and the information block that starts on row 12 (including the word dyslexia.)

I added the student sheets containing the info block.

This is the line that's yellow in the code: lRStN = wsTData.Cells(RowsTData.Count, lC).End(xlUp).Row
 
Upvote 0
Ah, something messed up in that line. Don't know how that happened.
Code: 
lRStN = wsTData.Cells(wsTData.Rows.Count, lC).End(xlUp).Row[\code]
 
Upvote 0
sijpie said:
Ah, something messed up in that line. Don't know how that happened.
Code: 
lRStN = wsTData.Cells(wsTData.Rows.Count, lC).End(xlUp).Row[\code]
Click to expand...
Got it. But now it's saying that this row is wrong.

wsTData.Range(wsTData.Cells(1, sCol), wsTData.Cells(lLastR, sCol)).AutoFilter Field:=1, Criteria1:=wsTData.Cells(lX, c)

🤷‍♀️
 
Upvote 0
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
 
Upvote 0
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...
Here's the error it's showing Function GetRowsinAreas(rRng As Range) As Long
 
Upvote 0
You must log in or register to reply here.

Similar threads

O
  • Question Question
Creating workbooks for a team of staff
Replies
1
Views
211
HighAndWilder
H
R
  • Question Question
[VBA] - Need to Hide one column and need sum of columns
Replies
0
Views
197
rsolanki
R
V
  • Solved
Need VBA to split data into multiple sheets paste formulas, formatting AND data validation
Replies
2
Views
123
vanessavalentino83
V
J
  • Question Question
I need to rename a Sheet
Replies
1
Views
514
CSmith
CSmith
J
  • Solved
Sheet Names to long when creating New worksheet
Replies
3
Views
653
mumps
mumps

Forum statistics

Threads
1,224,823
Messages
6,181,177
Members
453,021
Latest member
Justyna P

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