Excel VBA Dynamic Ranges

Question

I'm looking to improve my code to dynamically set ranges where data exist instead of hard coding the values. The starting value of the range will never change, but the ending value will if more month columns are added. What is the best way to approach this. Would be easier to make the range user defined?

Here's what I have:

The code will split data by unique group name starting at C5 into separate worksheets.

Public Sub Splitdatatosheets()
' Splitdatatosheets Macro
Dim Rng As Range
Dim Rng1 As Range
Dim vrb As Boolean
Dim sht As Worksheet

'Find unique value for splitting
Set Rng = Sheets("Sheet1").Range("C5")

'Find starting row to copy (Re-code to dynamically set)
Set Rng1 = Sheets("Sheet1").Range("A5:M5")

vrb = False

Do While Rng <> ""

    For Each sht In Worksheets

        If sht.Name = Left(Rng.Value, 31) Then

            sht.Select

            Range("A2").Select

            Do While Selection <> ""

                ActiveCell.Offset(1, 0).Activate

            Loop

            Rng1.Copy ActiveCell

            ActiveCell.Offset(1, 0).Activate

            Set Rng1 = Rng1.Offset(1, 0)

            Set Rng = Rng.Offset(1, 0)

            vrb = True

        End If

    Next sht

    If vrb = False Then

    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = Left(Rng.Value, 31)

    'Copy header rows (Re-code to dynamically set) to new worksheet first cell
    Sheets("Sheet1").Range("A4:M4").Copy ActiveSheet.Range("A1")

    Range("A2").Select

    Do While Selection <> ""

        ActiveCell.Offset(1, 0).Activate

    Loop

    Rng1.Copy ActiveCell

    Set Rng1 = Rng1.Offset(1, 0)

    Set Rng = Rng.Offset(1, 0)

    End If

vrb = False

Loop

End Sub

Answer 1

Here's the updated code for anyone who stumbles across this question.

Public Sub Splitdatatosheets()
' Splitdatatosheets Macro
Dim rng As Range
Dim Rng1 As Range
Dim Rng2 As Range
Dim vrb As Boolean
Dim sht As Worksheet
Dim R_Start, R_End, H_Start, H_End As Range

'Set Header
Set H_Start = Cells(4, 1)
Set H_End = H_Start.End(xlToRight)

'Set Data range
Set R_Start = Cells(5, 1)
Set R_End = R_Start.End(xlToRight)

'Find unique value for splitting
Set rng = Sheets("Sheet1").Range("C5")

'Find starting row to copy
Set Rng1 = Range(R_Start, R_End)
Set Rng2 = Range(H_Start, H_End)

vrb = False

Do While rng <> ""

    For Each sht In Worksheets

        If sht.Name = Left(rng.Value, 31) Then

            sht.Select

            Range("A2").Select

            Do While Selection <> ""

                ActiveCell.Offset(1, 0).Activate

            Loop

            Rng1.Copy ActiveCell

            ActiveCell.Offset(1, 0).Activate

            Set Rng1 = Rng1.Offset(1, 0)

            Set rng = rng.Offset(1, 0)

            vrb = True

        End If

    Next sht

    If vrb = False Then

    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = Left(rng.Value, 31)

    'Copy header rows to new worksheet first cell
    Rng2.Copy ActiveSheet.Range("A1")

    Range("A2").Select

    Rng1.Copy ActiveCell

    Set Rng1 = Rng1.Offset(1, 0)

    Set rng = rng.Offset(1, 0)

    End If

vrb = False

Loop

End Sub