Iterating over a column and setting values in multiple sheets

Question

I'm a programming newbie so please bear with me.

I currently have a sheet, Sheet1 "DataSheet", holding string (text) data over an undefined amount of rows in Columns A, B and C. Sheet2 "BlankSheet" is a template "Score Card" which I must duplicate indefinitely based on total rows of data entry in "DataSheet". I did this using a command button.

Sub Button2_Click()
    Dim i As Long
    Dim xNumber As Integer
    Dim xName As String
    Dim xActiveSheet As Worksheet
    On Error Resume Next
    Application.ScreenUpdating = False
    Set xActiveSheet = ThisWorkbook.Worksheets("BlankSheet")
    xNumber = Range("J2")
    For i = 1 To xNumber
        xName = ActiveSheet.Name
        xActiveSheet.Copy after:=ActiveWorkbook.Sheets(xName)
        ActiveSheet.Name = "Individual Score Sheet" & i
    Next
    xActiveSheet.Activate
    Application.ScreenUpdating = True
    CommandButton1.Enabled = False
End Sub

With the appropriate amount of Score Sheets created, I need to export personal data from "DataSheet" from Columns A, B and C to each Score Card.

ex:

1. "DataSheet" Cell A2 needs to go to "Individual Score Sheet1" Range A6:E6 (Merged Cell), "DataSheet" Cell B2 to "Individual Score Sheet1" Range F6:I6 (Merged Cell), and "DataSheet" Cell C2 to Individual Score Sheet1" Range J6:N6 (Merged Cell)

2. "DataSheet" Cell A3 needs to go to "Individual Score Sheet2" Range A6:E6 (Merged Cell), "DataSheet" Cell B3 to "Individual Score Sheet2" Range F6:I6 (Merged Cell), and "DataSheet" Cell C3 to Individual Score Sheet2" Range J6:N6 (Merged Cell)

etc, etc.. Until rows are blank.

So far I have:

Sub Button3_Click()

    Dim ws As Worksheet
    Application.ScreenUpdating = False
    
    With Sheet1
    
        For Each r In .Range("A1", .Range("A1").End(xlDown))
        
            For Each ws In Sheets
        
                Select Case ws.Name
                    Case "DataSheet", "BlankSheet"
                
                    Case Else

                    ws.Select
                    ws.Range("A6") = r
                
                End Select
                
            Next ws
                
        Next r
        
    End With

    Application.ScreenUpdating = True

End Sub

The program accurately ignores "DataSheet" and "BlankSheet", iterates down the data in Column A and ends when there is no data, and iterates across the other Worksheets, however it only sets the value of each worksheet to the final iteration of data in Column A.

I haven't tried to make Column B or C work, yet. The goal is to automate generation of "x" amount of "Score Cards" to print.

How can I rework this to iterate the data into the "Individual Score Sheet#" Worksheets as it works down the rows in Columns A, B and C?

Is it possible to combine those two buttons into one command?

Thanks in advance!

Answer 1

This code should do everything in one subroutine and can be called from an individual button.

Option Explicit

Sub Button2_Click()
Dim wsData As Worksheet
Dim wsScore As Worksheet
Dim wsTemp As Worksheet
Dim rngSrc As Range
Dim idx As Long

    Application.ScreenUpdating = False
    
    Set wsData = ThisWorkbook.Sheets("DataSheet")
    Set rngSrc = wsData.Range("A2")
    
    Set wsTemp = ThisWorkbook.Worksheets("BlankSheet")
    
    Do
        wsTemp.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        Set wsScore = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        idx = idx + 1
        With wsScore
            .Name = "Individual Score Sheet" & idx
            rngSrc.Copy .Range("A6:E6")
            rngSrc.Offset(, 1).Copy .Range("F6:I6")
            rngSrc.Offset(, 2).Copy .Range("J6:N6")
        End With
        
        Set rngSrc = rngSrc.Offset(1)
    Loop Until rngSrc.Value = ""
   
    Application.ScreenUpdating = True
    
    CommandButton1.Enabled = False
    
End Sub

Answer 2

Create Sheets from Template

Source Setup

Datasheet

Blanksheet

Result

Individual Score Sheet1 to 3

Standard Module e.g. Module1

Option Explicit

Sub CopySheets()
    
    Const sName As String = "Datasheet"
    Const sFirst As String = "A2:C2"
    
    Const nName As String = "Blanksheet"
    
    Const dRangesList As String = "A6,F6,J6"
    Const dPattern As String = "Individual Score Sheet"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range
    Dim srCount As Long, scCount As Long
    With sws.Range(sFirst)
        Dim slCell As Range
        Set slCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , xlByRows, xlPrevious)
        If slCell Is Nothing Then Exit Sub
        scCount = .Columns.Count
        srCount = slCell.Row - .Row + 1
        Set srg = .Resize(srCount)
    End With
    
    Dim nws As Worksheet: Set nws = wb.Worksheets(nName)
    
    Dim dRanges() As String: dRanges = Split(dRangesList, ",")
    
    Application.ScreenUpdating = False
    
    Dim dws As Worksheet
    Dim srrg As Range
    Dim r As Long, c As Long
    Dim dSheetName As String
    
    For r = 1 To srCount
        Set srrg = srg.Rows(r)
        dSheetName = dPattern & r
        Application.DisplayAlerts = False
        DeleteExistingSheet wb, dSheetName
        Application.DisplayAlerts = True
        nws.Copy After:=wb.Sheets(wb.Sheets.Count)
        Set dws = ActiveSheet
        dws.Name = dSheetName
        For c = 1 To scCount
            dws.Range(dRanges(c - 1)).Value = srrg.Cells(c).Value
        Next c
    Next r
    
    Application.ScreenUpdating = True

End Sub

Sub DeleteExistingSheet( _
        ByVal wb As Workbook, _
        ByVal SheetName As String)
    On Error Resume Next
    Dim sh As Object: Set sh = wb.Sheets(SheetName)
    On Error GoTo 0
    If Not sh Is Nothing Then
        sh.Delete
    End If
End Sub

Sheet Module e.g. Datasheet or Blanksheet

Option Explicit

Private Sub CommandButton1_Click()
    CopySheets
End Sub