开发者

Searching Worksheet for Similar Rows to Group Together Excel VBA

I have a worksheet with headers listed in the top row. I also have data listed in rows below. This data is to remain grouped together as a row, and cannot change position relative to one another. However, the entire row can move freely. Each header describes a data type of the row below.

I want to be able to:

  1. Tell the macro in what column to look to group rows. For ease, we'll call this Col D
  2. Look through entire worksheet.
  3. Move similar rows so they are grouped together.***
  4. Add group to a selection

*Note I will also be marking groups with an integer in column Z to show the group is a group

The problem I am having is with the following line of my sub FindRow:

ActiveSheet.Range(curRange).Resize (resizeRng)

Dubug says curRange = "Elevator" which is the value of a cell, but not a range, yet I define it up above:

inRange = "A" & rngStart & ":" & Mid(alphabet, totHdrLngth, 1) & belowRowCount
Set curRange = ActiveSheet.Range(inRange)

For reference I explain the overall code below:

CreateGroup - checks if subsequent rows have the same value in Col D. If so it marks this group as a unique integer, and increases selection. If not FindRow is called.

FindRow - searches the entire worksheet for row (row1) having same value in Col D. If found, calls rowSwapper to swap the found row (row2) with the row below row1.

RowSwapper - function takes in two row numbers, and swaps them.

Here's the sub CreateGroup:

Public Sub CreatGroup()
Dim letterCount As Integer
Dim letString, label, inRange As String
Dim rowSelect, marker, rowStart, rowCount, rngStart, count As Long

'Predefine necessary variables
marker = 1
rowCount = 2 'Start at  row 2, excluding header
rowStart = 2 'For range reference to create group
belowRowCount = 3 'start below rowCount
isGroup = False
count = 1

'Loop through each cell in column D to determine if consecutive metrics have the same value
'If true, while loop sorts each series of consecutive metrics individually
Do
    curCellVal = ActiveSheet.Range("D" & rowCount).Value  'Returns value rowCount(th) row of "Metric" column
    nextCellVal = ActiveSheet.Range("D" & belowRowCount).Value 'Returns the value of the row under rowCount
    marker = 1
    resizeRng = 0

    'Makes a cell selection while cell values in column 4 are equal
    If curCellVal = nex开发者_StackOverflow社区tCellVal Then '<<<NECESSARY?
        isGroup = True   'Designates group has been found
        If resizeRng = 0 Then
            rngStart = rowCount
        End If
        'rowStart = ActiveSheet.Row

        'Resize selection to include cell with same metric name
        inRange = "A" & rngStart & ":" & Mid(alphabet, totHdrLngth, 1) & belowRowCount
        Set curRange = ActiveSheet.Range(inRange)

        'Establish place holder in col "Z" (empty) to track groups
        ActiveSheet.Range("Z" & rowCount).Value = marker
        ActiveSheet.Range("Z" & belowRowCount).Value = marker

        resizeRng = resizeRng + 1
        rowCount = rowCount + resizeRng
        belowRowCount = rowCount + 1

    ElseIf curCellVal <> nextCellVal Then 'And isGroup = True Then

        FindRow rowCount

        'Re-establish rowCount to account for cells that may have been added to group
        rowCount = rowCount + resizeRng
        belowRowCount = rowCount + 1
    Else
        rowCount = rowCount + 1
        belowRowCount = rowCount + 1
    End If

    'to prevent subsequent groups of metrics from being labeled together
    marker = marker + 1

    isGroup = False
Loop While rowCount <= totCount

End Sub

Also, for additional reference, these subs are part of a larger program described here: Sorting Groups of Rows Excel VBA Macro

Let me know your thoughts...


If you want to get the cell range address, you just need to say rng.Address. Just specifying that you want rng is the same (essentially) as saying rng.Value

As for the line:

ActiveSheet.Range(curRange).Resize (resizeRng)

You may want to try

ActiveSheet.Range(curRange).Cells.Resize (resizeRng)

I was playing around with some formatting last night on a little project of my own and ran into a similar error.

Hope that helps.

0

上一篇:

下一篇:

精彩评论

暂无评论...
验证码 换一张
取 消

最新问答

问答排行榜