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

Excel VBA动态范围

1 个答案: