Excel VBA 动态范围答案

【问题标题】：Excel VBA Dynamic RangesExcel VBA 动态范围
【发布时间】：2015-10-01 20:29:40
【问题描述】：

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

这是我所拥有的：

代码将按从 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

【问题讨论】：

你谷歌“vba 找到最后一行”没有引号吗？当您不知道如何开始某事时，这通常是一个不错的起点。 FWIW，我使用这种方法：rondebruin.nl/win/s9/win005.htm（这是众多方法之一......）
这不起作用Do While Selection <> "" ActiveCell.Offset(1, 0).Activate Loop也检查一下xlorate.com/selection-codes.html
感谢您提供的链接，我能够弄清楚。很简单！

标签： vba excel

【解决方案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

【讨论】：