Loop range and copy to different sheets in the same workbook

[alfredgomez]

I have a multi-sheet workbook (.xlsm). The 1st sheet is a master sheet, editable, and contains all the data.
The other sheets (Classroom #) are subsets of the master based on which classroom the students are assigned to.

Basically, via individual formula's in the classroom sheets, I was able to copy the student information over to each individual classroom sheet based on the students assigned to the classroom.

The problem is that there are gaps on the classroom sheets where the other classroom students on the master were.

I need to use vba code to
- Select a range on the master sheet (B9:Q83)
- Loop through each row in the range
- Check the classroom value, Cell Q, of currently indexed row in the range.
- Based on the value of Cell Q above, copy range B through P of indexed row, to the appropriate classroom sheet starting from cell B9 of the classroom sheet so that there are no gaps.
- Classroom sheets are numbered (1,2,4,5,7,X).
- Classroom X denotes the student withdrew from the program so they should be skipped.

I tried to figure this out using the many sample vba programs on your site but have become overwhelmed by just trying to understand the code and how to modify it to suit my needs.

Thank you in advance for all of your help
Alfred Gomez
I.T. Coordinator
YMCA of Paterson

 

[Trebor76]

Hi Alfred,

Welcome to MrExcel!!

I think your ranges are out as I make it that the classroom number should be in Col. R. I have created a variable for this which you would simply change (along with two other commented lines) if needed:

Option Explicit
Sub Macro1()

    Dim i As Long, j As Long, x As Long
    Dim wsSrc As Worksheet, ws As Worksheet
    Dim strRoomNum As String
  
    Application.ScreenUpdating = False
  
    Set wsSrc = ThisWorkbook.Sheets("Master Sheet") '<-Sheet name with the editable data. Change to suit.
    strRoomNum = "R" '<-Column containing the classroom number in the 'wsSrc' tab. Change to suit.
    j = wsSrc.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  
    On Error Resume Next
        For i = 9 To j
            If IsNumeric(wsSrc.Range(strRoomNum & i)) = True Then
                Set ws = ThisWorkbook.Sheets(CStr("Classroom " & wsSrc.Range(strRoomNum & i)))
                If ws Is Nothing Then
                    MsgBox "There is no tab called """ & CStr("Classroom " & wsSrc.Range(strRoomNum & i)) & """." & vbNewLine & "Please create it and try again.", vbExclamation
                    Application.ScreenUpdating = True
                    On Error GoTo 0
                    Exit Sub
                Else
                    x = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    x = IIf(x = 0, 9, x + 1)
                    wsSrc.Range("B" & i & ":Q" & i).Copy Destination:=ws.Range("B" & x) '<-Copies columns B to Q to the next available row in column B of the 'ws' tab. Change to suit.
                    x = 0
                End If
            End If
        Next i
    On Error GoTo 0
  
    MsgBox "Data has now been copied.", vbInformation

End Sub

Note too that you could just filter the data in the Master Sheet by classroom to give you the required dataset instead of creating identical tabs to do the same which in my humble opinion is not very efficient.

Regards,

Robert

 

[alfredgomez]

Hi Alfred,

Welcome to MrExcel!!

I think your ranges are out as I make it that the classroom number should be in Col. R. I have created a variable for this which you would simply change (along with two other commented lines) if needed:

Option Explicit
Sub Macro1()

    Dim i As Long, j As Long, x As Long
    Dim wsSrc As Worksheet, ws As Worksheet
    Dim strRoomNum As String
 
    Application.ScreenUpdating = False
 
    Set wsSrc = ThisWorkbook.Sheets("Master Sheet") '<-Sheet name with the editable data. Change to suit.
    strRoomNum = "R" '<-Column containing the classroom number in the 'wsSrc' tab. Change to suit.
    j = wsSrc.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
 
    On Error Resume Next
        For i = 9 To j
            If IsNumeric(wsSrc.Range(strRoomNum & i)) = True Then
                Set ws = ThisWorkbook.Sheets(CStr("Classroom " & wsSrc.Range(strRoomNum & i)))
                If ws Is Nothing Then
                    MsgBox "There is no tab called """ & CStr("Classroom " & wsSrc.Range(strRoomNum & i)) & """." & vbNewLine & "Please create it and try again.", vbExclamation
                    Application.ScreenUpdating = True
                    On Error GoTo 0
                    Exit Sub
                Else
                    x = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    x = IIf(x = 0, 9, x + 1)
                    wsSrc.Range("B" & i & ":Q" & i).Copy Destination:=ws.Range("B" & x) '<-Copies columns B to Q to the next available row in column B of the 'ws' tab. Change to suit.
                    x = 0
                End If
            End If
        Next i
    On Error GoTo 0
 
    MsgBox "Data has now been copied.", vbInformation

End Sub

Note too that you could just filter the data in the Master Sheet by classroom to give you the required dataset instead of creating identical tabs to do the same which in my humble opinion is not very efficient.

Regards,

Robert

Robert,

First, Thank You for the immediate reply.
My expectations were that I would get a reply about a month from now.

Second, This code is excellent. You are a master at VBA.

Things I can tweak...
The room numbers are in col "Q".
The range of cells to copy should be from B.i - P.i., as the classroom sheets do not have a Q col for the classroom.

Things I don't fully understand.
The data does get copied to the correct sheet but not starting from the first blank of each sheet (B9).

I'm going to clear the existing data in those sheets and run the code again.
Perhaps I have to clear the data so that the fields are empty before running the code or I have to figure out the for loop part of the code.

I thank you for all your help.
Alfred Gomez
I.T. Coordinator
YMCA of Paterson

 

[alfredgomez]

Robert,

First, Thank You for the immediate reply.
My expectations were that I would get a reply about a month from now.

Second, This code is excellent. You are a master at VBA.

Things I can tweak...
The room numbers are in col "Q".
The range of cells to copy should be from B.i - P.i., as the classroom sheets do not have a Q col for the classroom.

Things I don't fully understand.
The data does get copied to the correct sheet but not starting from the first blank of each sheet (B9).

I'm going to clear the existing data in those sheets and run the code again.
Perhaps I have to clear the data so that the fields are empty before running the code or I have to figure out the for loop part of the code.

I thank you for all your help.
Alfred Gomez
I.T. Coordinator
YMCA of Paterson

Robert,

I found another bit of code that placed the data starting at B9 of each sheet.
"x = ws.Range("B9:B23").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row"

I now need to ..
1 - add code to blank out range B9:P23 of each sheet Prior to running code.
2 - Figure out why sheet Classroom 5 sheet has extra copied data.
The Master Sheet shows that classroom 5 is the last referenced classroom number used.

 

[alfredgomez]

Robert,

I found another bit of code that placed the data starting at B9 of each sheet.
"x = ws.Range("B9:B23").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row"

I now need to ..
1 - Add code to blank out range B9:P23 of each sheet Prior to running code.
2 - Figure out why sheet Classroom 5 sheet has extra copied data.
The Master Sheet shows that classroom 5 is the last referenced classroom number used.

I changed the data in the master sheet to reflect the last classroom as number 1. The extra data copied to classroom 1. I'll have to tweak the IsNumeric statement as I think it needs to check for blanks as well. Perhaps it equates blanks as zero.

 

[alfredgomez]

Robert,

I'm sure there is a more elegant way to clear the sheets and check for blanks, but this is what I came up with.

Sub Copy_To_Sheets()

Dim i As Long, j As Long, x As Long, s As Long
Dim wsSrc As Worksheet, ws As Worksheet
Dim strRoomNum As String

Application.ScreenUpdating = False

Set wsSrc = ThisWorkbook.Sheets("Master Sheet") '<-Sheet name with the editable data. Change to suit.
strRoomNum = "Q" '<-Column containing the classroom number in the 'wsSrc' tab. Change to suit.
j = wsSrc.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row


On Error Resume Next
'Blank out Classroom Sheets
s = Application.Sheets.Count
For i = 2 To s
Sheets(i).Select
Range("B9:P23").Select
ActiveCell.FormulaR1C1 = ""
Selection.ClearContents
Next i

For i = 9 To j
If wsSrc.Range(strRoomNum & i) <> "" Then
If IsNumeric(wsSrc.Range(strRoomNum & i)) Then
Set ws = ThisWorkbook.Sheets(CStr("Classroom " & wsSrc.Range(strRoomNum & i)))
If ws Is Nothing Then
MsgBox "There is no tab called """ & CStr("Classroom " & wsSrc.Range(strRoomNum & i)) & """." & vbNewLine & "Please create it and try again.", vbExclamation
Application.ScreenUpdating = True
On Error GoTo 0
Exit Sub
Else
'x = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
x = ws.Range("B9:B23").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
x = IIf(x = 0, 9, x + 1)
wsSrc.Range("B" & i & ":P" & i).Copy Destination:=ws.Range("B" & x) '<-Copies columns B to P to the next available row in column B of the 'ws' tab. Change to suit.
x = 0
End If
End If
End If
Next i
On Error GoTo 0

MsgBox "Data has now been copied.", vbInformation

End Sub

 

[Trebor76]

I'm sure there is a more elegant way to clear the sheets and check for blanks, but this is what I came up with.

As long as you've got it working that's the main thing. You can always tweak it from there.

I'm glad we were able to provide you with a workable solution

Regards,

Robert

 

[Trebor76]

Actually I have made some modifications to the code as follows. Note you use a static range of B9:P23 - will this always be the case?

Option Explicit
Sub Copy_To_Sheets()

    Dim i As Long, j As Long, x As Long, s As Long
    Dim wsSrc As Worksheet, ws As Worksheet
    Dim strRoomNum As String
    
    Application.ScreenUpdating = False
    
    Set wsSrc = ThisWorkbook.Sheets("Master Sheet") '<-Sheet name with the editable data. Change to suit.
    strRoomNum = "Q" '<-Column containing the classroom number in the 'wsSrc' tab. Change to suit.
    j = wsSrc.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    On Error Resume Next
        'Blank out Classroom Sheets using a static range B9:P23
        s = Application.Sheets.Count
        For i = 2 To s
            ThisWorkbook.Sheets(i).Range("B9:P23").ClearContents 'Anything outside this range will be ignored perhaps throwings out
        Next i
        
        For i = 9 To j
            If Len(wsSrc.Range(strRoomNum & i)) > 0 And IsNumeric(wsSrc.Range(strRoomNum & i)) Then
                Set ws = ThisWorkbook.Sheets(CStr("Classroom " & wsSrc.Range(strRoomNum & i)))
                If ws Is Nothing Then
                    MsgBox "There is no tab called """ & CStr("Classroom " & wsSrc.Range(strRoomNum & i)) & """." & vbNewLine & "Please create it and try again.", vbExclamation
                    Application.ScreenUpdating = True
                    On Error GoTo 0
                    Exit Sub
                Else
                    x = ws.Range("B9:B23").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 'Only finds the last row from B9:B23.  What if there's data below this?
                    x = IIf(x = 0, 9, x + 1)
                    wsSrc.Range("B" & i & ":P" & i).Copy Destination:=ws.Range("B" & x) '<-Copies columns B to P to the next available row in column B of the 'ws' tab. Change to suit.
                    x = 0
                End If
            End If
        Next i
    On Error GoTo 0

    MsgBox "Data has now been copied.", vbInformation

End Sub

 

[Trebor76]

Actually these lines will clear all sheets - including the Master Sheet tab:

 'Blank out Classroom Sheets using a static range B9:P23
        s = Application.Sheets.Count
        For i = 2 To s
            ThisWorkbook.Sheets(i).Range("B9:P23").ClearContents 'Anything outside this range will be ignored perhaps throwings out
        Next i

I doubt you want that - right?

 

[alfredgomez]

Robert,
Your code is accurate and much cleaner / elegant than what I was able to piece together.
It works perfectly. The 'Blank out classroom sheets works to clear sheets starting from Sheet 2 thru the last sheet in the workbook so it ignores Master Sheet as long as the position of the Master Sheet does not change in the pecking order.

I guess to make it dummy proof I could start from Sheet 1, test if it is titled "Master Sheet" and ignore blank process if it is.
I think I can figure that part out.

Thank You for all your help, prompt response and expertise.
I definitely would not have figured this out without you or this website's resources.
Five Stars (*****)

Thank You
Alfred Gomez
I.T. Coordinator
YMCA of Paterson