Macro to Copy Dynamic Range of Highlighted Rows

[tatertot]

Hi,

This is my 1st using this forum and also VBA. I am in the process of writing a VBA code to generate my finished month end reports by clicking a created macro button.

In this process I have ran into a snag. The snag....

In column G, I have asset classes. There are 3 specific asset classes I have to find. When found, I have the entire row highlighted through code (macro). What I am wanting now is to copy those highlighted rows and paste into a new worksheet starting on row 5. The range of data will be dynamic month to month. So I would need the code to search from row 5 onward to know the exact highlighted cells.

A) Is this even attainable?
B) If so, any and all suggestions would be so very much appreciated!!
C) If not, are there better links that I am having oversight on that could make this easier and more efficient?

 

[MARK858]

A) Is this even attainable?

Yes

I have the entire row highlighted through code (macro).

Post the code as both can probably be done in 1 action

 

[tatertot]

Thanks so much for the reply MARK858! I have pasted my color coding of the asset classes below. They are highlighted yellow. Once that formatting has been applied to the dynamic range of rows, that is what I would like to paste into a new sheet starting in A5.


'color code the AUC asset classes
Const TEST_COLUMN As String = "G" '<=== change to suit
Dim LastRow As Long
Dim cell As Range

With Worksheets(2)
LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row

For Each cell In Range("G5:G" & LastRow)
If cell.Value = "US1648AM" Then
cell.EntireRow.Interior.ColorIndex = 43
ElseIf cell.Value = "US1648AT" Then
cell.EntireRow.Interior.ColorIndex = 43
ElseIf cell.Value = "US1648AB" Then
cell.EntireRow.Interior.ColorIndex = 43
Else
cell.EntireRow.Interior.ColorIndex = xlNone
End If
Next
End With

 

[MARK858]

Test on a copy of your workbook (let me know if it is too slow)

Sub copyrow()
    'color code the AUC asset classes
    Const TEST_COLUMN As String = "G"    '<=== change to suit
    Dim LastRow As Long
    Dim cell As Range
    Application.ScreenUpdating = False
    
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "mySht"
    With Worksheets(2)
        LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row

        For Each cell In .Range("G5:G" & LastRow)
            
            If cell.Value = "US1648AM" Or cell.Value = "US1648AT" Or cell.Value = "US1648AB" Then
                cell.EntireRow.Interior.ColorIndex = 43
                If Sheets("mySht").Range("A" & Rows.Count).End(xlUp).Row < 5 Then
                    cell.EntireRow.Copy Sheets("mySht").Range("A5")
                Else
                    cell.EntireRow.Copy Sheets("mySht").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                End If
            Else
                cell.EntireRow.Interior.ColorIndex = xlNone
            End If
        
        Next
    End With
    
    Application.ScreenUpdating = True
End Sub

 

[MARK858]

A little better without changing the code dramatically.

Sub copyrow()
    'color code the AUC asset classes
    Const TEST_COLUMN As String = "G"    '<=== change to suit
    Dim LastRow As Long
    Dim cell As Range
    Application.ScreenUpdating = False
    
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "mySht"
    With Worksheets(2)
        LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
       .UsedRange.Offset(4).Resize(.UsedRange.Rows.Count - 4, Columns.Count).Interior.ColorIndex = xlNone

        For Each cell In .Range("G5:G" & LastRow)
            
            If cell.Value = "US1648AM" Or cell.Value = "US1648AT" Or cell.Value = "US1648AB" Then
                cell.EntireRow.Interior.ColorIndex = 43
                If Sheets("mySht").Range("A" & Rows.Count).End(xlUp).Row < 5 Then
                    cell.EntireRow.Copy Sheets("mySht").Range("A5")
                Else
                    cell.EntireRow.Copy Sheets("mySht").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                End If
            End If
        
        Next
    End With
    
    Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

.. another option which should be considerably faster if you have much data. It doesn't require looping through each cell in the column & only does one copy across to the new sheet.
If it is certain that there will always be some rows to copy, the code could be trimmed a bit by removing the blue lines.

Edit: Code assumes column Z is available to use as a helper. If not another column could be nominated or the code could find such a vacant column to use.

Sub HighlightAndCopy()
  Const TEST_COLUMN As String = "G" '<=== change to suit
  Dim adr As String
  Dim wsDest As Worksheet
  Dim rCopy As Range
  
  Application.ScreenUpdating = False
  With Worksheets(2)
    .Activate
    adr = TEST_COLUMN & "5:" & TEST_COLUMN & .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
    With Intersect(.Columns("Z"), .Range(adr).EntireRow)
      .Value = Evaluate(Replace("if(#=""US1648AM"",1,if(#=""US1648AT"",1,if(#=""US1648AB"",1,"""")))", "#", adr))
      On Error Resume Next
      Set rCopy = .SpecialCells(xlConstants, xlNumbers).EntireRow
      On Error GoTo 0
      .ClearContents
      If rCopy Is Nothing Then
        MsgBox "No rows to copy"
      Else
        Set wsDest = Worksheets.Add(After:=Worksheets(2))
        With rCopy
          .Interior.ColorIndex = 43
          .Copy Destination:=wsDest.Range("A5")
        End With
      End If
    End With
  End With
  Application.ScreenUpdating = True
End Sub

 

[tatertot]

Thank you both Peter and Mark!! I piece I completely left out that would be vital in the code is that I technically want to cut the rows where the 3 asset classes are found to the new sheet and maintain the other asset classes on the original sheet the macro is ran on.

The current code copies the cells where it is true and pastes to a new worksheet (which is great!). The issue is that they still remain on the original worksheet that I do not want them on anymore.

Any chance this can be done??? Thanks so much again!!

 

[Peter_SSs]

The current code copies the cells where it is true and pastes to a new worksheet (which is great!). The issue is that they still remain on the original worksheet that I do not want them on anymore.

Any chance this can be done???

That's an easy change, but it does raise another question: If you are deleting them from the original sheet and having them on a new sheet of their own, do you really need them highlighted as well?

Anyway, just add this blue line of code where shown.

With rCopy
  .Interior.ColorIndex = 43 '?? Do you still need this??
  .Copy Destination:=wsDest.Range("A5")
  .EntireRow.Delete
End With

 

[tatertot]

Hi Peter,

I do not need to technically highlight them in the cutting process. If there is a better way to do this without highlighting them to then paste into the new sheet, I am all ears. Thanks so much for your assistance!!!

 

[MARK858]

Hi Peter,

I do not need to technically highlight them in the cutting process. If there is a better way to do this without highlighting them to then paste into the new sheet, I am all ears. Thanks so much for your assistance!!!

Remove the line Peter commented....

  .Interior.ColorIndex = 43 '?? Do you still need this??