Excel VBA动态范围

Question

我希望改进代码以动态设置数据存在的范围，而不是对值进行硬编码。 范围的起始值永远不会改变，但是如果添加更多月份列，则最终值将不变。 解决此问题的最佳方法是什么。 设置用户定义的范围会更容易吗？

这是我所拥有的：

该代码将从C5开始按唯一的组名将数据拆分为单独的工作表。

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

这是偶然遇到此问题的任何人的更新代码。

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