VBA Excel - Want to select 1 or more rows based on selected cells and copy to another sheet

user_14639693 0
Viewed 113

Forgive the ignorance, this is my first time really diving in to vba. I have 3 sheets Master contains a catalog with prices and attributes

plist contains a search button I created with a tutorial to filter results. I would like the user to be able to select one or more cells that are displayed and then click a button to copy rows over to New sheet

New is the ultimate destination for selected files. Rows would copy in order, top to bottom as they are clicked.

I've searched and tried a couple ideas, but my ignorance is really preventing me from moving forward. Would love a direction to search or any help you can provide.

TLDR: Need code to copy values from selected cells over to separate sheet.

vba excel
1 Answers

Rows of Non-Adjacent Cells

  • Copy the complete code into a standard module, e.g. Module1.
  • Only run (or assign to a button) the first procedure copyRowsOfSelectedCells. If run from VBE, make sure that worksheet plist is selected (active). 'plist' is also the worksheet containing the button.
  • The accompanying procedures are called by the first when necessary.
  • Before each of the accompanying procedures there is a method, property or function name which is most relevant in the following procedure to accomplish the task at hand. Study ('Google') those to better understand each of the procedures.

The Code

Option Explicit

Sub copyRowsOfSelectedCells()
    
    ' Define Destination Worksheet Name.
    Const dstName As String = "New"
    
    ' Test if Selection is a range (object).
    If Not isRange(Selection) Then
        GoTo ProcExit
    End If
    
    ' Define Source Row Ranges.
    Dim rng As Range
    Set rng = CollectedRowRanges(Selection)
        
    ' Define Destination First Cell Range.
    Dim cel As Range
    Set cel = FirstCell(rng.Worksheet.Parent.Worksheets(dstName))
    
    ' Copy from Source Worksheet to Destination Worksheet.
    copyRowsToAnotherWorksheet rng, cel
    
ProcExit:

End Sub

' TypeName Function
Private Function isRange(PossibleRange As Variant) _
  As Boolean
    If TypeName(PossibleRange) = "Range" Then
        isRange = True
    Else
        Debug.Print "Not a range."
    End If
End Function

' Range.Areas Property
Private Function CollectedRowRanges(SourceRange As Range) _
  As Range
    Dim bRng As Range
    Dim rng As Range
    Dim cel As Range
    For Each rng In SourceRange.Areas
        For Each cel In rng.Cells
            buildRange bRng, cel.EntireRow
        Next cel
    Next rng
    Set CollectedRowRanges = bRng
End Function

' Application.Union Method
Private Sub buildRange(ByRef BuiltRange As Range, _
                       AddRange As Range)
    If Not BuiltRange Is Nothing Then
        Set BuiltRange = Union(BuiltRange, AddRange)
    Else
        Set BuiltRange = AddRange
    End If
End Sub

' Range.Find Method
Private Function FirstCell(Sheet As Worksheet, _
                           Optional ByVal ColumnIndex As Variant = "A") _
  As Range
    Dim cel As Range
    Set cel = Sheet.Cells.Find(What:="*", _
                               LookIn:=xlFormulas, _
                               SearchOrder:=xlByRows, _
                               SearchDirection:=xlPrevious)
    If Not cel Is Nothing Then
        Set FirstCell = Sheet.Cells(cel.Row, ColumnIndex).Offset(1)
    Else
        Set FirstCell = Sheet.Cells(1, ColumnIndex)
    End If
End Function

' Range.PasteSpecial Method
Private Sub copyRowsToAnotherWorksheet(CopyRows As Range, _
                                       PasteCell As Range)
    If Not CopyRows Is Nothing And Not PasteCell Is Nothing Then
        Dim PasteRowCell As Range
        Set PasteRowCell = PasteCell.Cells(1).Offset(, 1 - PasteCell.Column)
        CopyRows.Copy
        PasteCell.Worksheet.Activate
        PasteRowCell.PasteSpecial xlPasteValues
        Application.CutCopyMode = False
    End If
End Sub
user_98140690
Related