Results 1 to 3 of 3
  1. #1
    Join Date
    Sep 2002
    Location
    NJ
    Posts
    139

    Unanswered: Cleaning and moving sorted rows upward to within a determined space on a sheet.

    Hi,

    win2k
    excel2k

    Here is my dilemma:

    On Sheet1 I have a space: range b6 : n30. Most columns with that space contain information, but only some must remain after clearing the space if column d contains an ‘X”. The problem is after cleaning up the space.

    For a better definition of the space, please see attachments. The attachments are to *.bmp files. Sheet.bmp represents the state of the sheet after clean up but before moving the rows upward. Sheet2.bmp represents the final product. That is where the rows should be when done.

    My problem is that once the space is cleared, then I need to move all the rows from within the space upward all the way up to b6 and accumulating downward for as many as there are.

    Here is my code, which is not very good. While it moves some rows depending on some conditions, the variety of possibility is so great that I cannot account for all of them. I have to copy, move up but if the row above is empty then ok paste but if the row above is not empty then move up one more, and so one…. I know about KISS and I want to keep it simple and I am sure there is a better way to do this. That is why I am writing this for help.

    this is my code:

    It starts at the bottom and goes upward to pick up the first cell that contains an 'x'. if so then it copies it and then moves upward to all the way up to cell B6. if B6 is empty then paste it, else go down one cell at the time until the first empty cell and the paste it. then using the "count" go back down to the copied cell and clear it. go upone row and restart the process all over again.

    Private Sub CommandButton1_Click()
    Dim irowcount As Integer
    Dim r As Integer
    Dim i As Integer
    Dim count As Integer
    With ActiveSheet
    irowcount = 30
    For r = irowcount To 1 Step -1 'from the bottom up
    If r = 6 Then
    Exit Sub
    End If
    Range("d" & r).Select
    If Range("d" & r).Value = "X" Then
    Range("b" & r & ":n" & r).Select
    Selection.Copy 'copy and move up
    Range("b" & r).Offset(-1, 0).Select
    r = r - 1
    count = 1
    For i = 25 To 1 Step -1
    If Range("b" & r).Value <> "" And r <> 6 Then
    Range("b" & r & ":n" & r).Offset(-1, 0).Select
    r = r - 1
    count = count + 1 'as loop moves upward count 1 so that it can find the copied cell on the way down.
    ElseIf Range("b" & r).Value = "" And r <> 6 Then
    Range("b" & r & ":n" & r).Offset(-1, 0).Select
    r = r - 1
    count = count + 1
    ElseIf Range("b" & r).Value = "" And r = 6 Then
    Range("b" & r & ":n" & r).Offset(1, 0).Select
    r = r + 1
    If Range("b" & r).Value = "" Then
    ActiveSheet.Paste
    Application.CutCopyMode = False
    End If
    ElseIf Range("b" & r).Value <> "" And r = 6 Then
    Dim j As Integer
    For j = 1 To count
    'Range("b" & r & ":n" & r).Offset(1, 0).Select
    'r = r + 1
    If Range("b" & r).Value = "" Then
    ActiveSheet.Paste 'paste and exit this for loop
    Application.CutCopyMode = False
    Exit For
    Else
    Range("b" & r & ":n" & r).Offset(1, 0).Select
    r = r + 1
    count = count - 1
    'Exit For
    End If
    Next j
    Dim jj As Integer
    For jj = 1 To count 'now go down to clear the copied cell range
    Range("B" & r).Select
    Range("b" & r).Offset(1, 0).Select
    r = r + 1
    If jj = count Then
    'r = r - 1
    Range("b" & r & ":n" & r).Clear
    Range("b" & r & ":n" & r).Offset(-1, 0).Select
    r = r - 1
    Exit For
    End If
    Next jj
    Exit For
    End If
    Next i
    End If
    If r = 6 Then
    Exit Sub
    End If
    Next r
    End With
    End Sub



    ps: sometime i see some of you post code in a window that is better to read. How does one do that on DBFORUM??
    Attached Thumbnails Attached Thumbnails sheet.bmp   sheet2.bmp  
    Last edited by Alexxx12; 09-05-04 at 14:11. Reason: BETTER CODE

  2. #2
    Join Date
    Jan 2004
    Location
    Aberdeen, Scotland
    Posts
    1,067
    Hi Alex

    is this the sort of thing you want

    Code:
    Private Sub CommandButton1_Click()
    Dim i As Integer
    'object Variables
    Dim rngX As Range
    Dim rngBlank As Range
    
        'arbitary values for loop from range
        For i = 6 To 30
            'Find the Last Instance of X
            Set rngX = Range("D6:D30").Find("X", , , , , xlPrevious)
            'if found find the first blank cell
            If Not rngX Is Nothing Then
                Set rngBlank = Range("D6:D" & rngX.Row).Find("", , , , , xlNext)
                'if a blank cell is found then move copied cell
                If Not rngBlank Is Nothing Then
                    Range("B" & rngBlank.Row & ":N" & rngBlank.Row).Value = _
                            Range("B" & rngX.Row & ":N" & rngX.Row).Value
                    Range("B" & rngX.Row & ":N" & rngX.Row).Clear
                    Application.CutCopyMode = False
                Else
                    'if no blank space found exit for loop
                    Exit For
                End If
            Else
                'if no value found Exit for loop
                Exit For
            End If
        Next i
        
        MsgBox "Done"
        'set object variables to Nothing
        Set rngX = Nothing
        Set rngBlank = Nothing
    End Sub
    we can do more if required this code picks the first cell in column D with an X in it and then pastes it into the first blank area in your area

    if you just want to keep the same order it's already in you can just do this

    Code:
    Range("B6:N30").Sort Range("D6"), xlAscending
    oh and to get the code window up type [ code ] at the start of your code and [ /code ] at the end of your code (witout the spaces)

    HTH
    Dave

  3. #3
    Join Date
    Sep 2002
    Location
    NJ
    Posts
    139

    move rows upward

    Hi,

    Thank you for you help. Your code is by far, simpler, clearner, definetly shorter and efficient.

    I eventually got my to work, but it is far longer harder to ready and less efficient.

    Code:
        Dim irowcount As Integer
        Dim r As Integer
        Dim i As Integer
        Dim count As Integer
        With ActiveSheet
            irowcount = 30
            For r = irowcount To 1 Step -1
                If r = 5 Then
                    Exit Sub
                End If
                Range("d" & r).Select
                If Range("d" & r).Value = "X" Then
                    Range("b" & r & ":n" & r).Select
                    Selection.Copy
                    Range("b" & r).Offset(-1, 0).Select
                    r = r - 1
                    count = 1
                    For i = 25 To 1 Step -1
                        If Range("b" & r).Value <> "" And r <> 5 Then
                            Range("b" & r & ":n" & r).Offset(-1, 0).Select
                            r = r - 1
                            count = count + 1
                        ElseIf Range("b" & r).Value = "" And r <> 5 Then
                            Range("b" & r & ":n" & r).Offset(-1, 0).Select
                            r = r - 1
                            count = count + 1
                        ElseIf Range("b" & r).Value = "" And r = 5 Then
                                Range("b" & r & ":n" & r).Offset(1, 0).Select
                                r = r + 1
                            If Range("b" & r).Value = "" Then
                                ActiveSheet.Paste
                                Application.CutCopyMode = False
                            End If
                        ElseIf Range("b" & r).Value <> "" And r = 5 Then
                            Dim j As Integer
                            For j = 1 To count
                                    'Range("b" & r & ":n" & r).Offset(1, 0).Select
                                    'r = r + 1
                                    If Range("b" & r).Value = "" Then
                                        ActiveSheet.Paste
                                        Application.CutCopyMode = False
                                        Exit For
                                    Else
                                        Range("b" & r & ":n" & r).Offset(1, 0).Select
                                        r = r + 1
                                        count = count - 1
                                        'Exit For
                                    End If
                            Next j
                            Dim jj As Integer
                            For jj = 1 To count
                                  Range("B" & r).Select
                                  Range("b" & r).Offset(1, 0).Select
                                  r = r + 1
                                  If jj = count Then
                                      'r = r - 1
                                      Range("b" & r & ":n" & r).Clear
                                      'Range("b" & r & ":n" & r).Offset(-1, 0).Select
                                      'r = r - 1
                                      Exit For
                                  End If
                            Next jj
                           Exit For
                        End If
                    Next i
                End If
                If r = 5 Then
                   Exit Sub
                End If
            Next r
        End With

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •