Copy and Paste Rows from 2 different sources and delete said rows

[John_C4439]

I'll try and word this the best I can. I have a spreadsheet with clients products in it. The spreadsheet is an extract from our CRM software.

the relevant spreadsheets used in this code are:

1. Output Sheet --> this is taken from the CRM software to just display product codes
2. Fixed --> this spreadsheet takes any product codes with 5 or more characters in their string and adds it to this page, subtotals it
3. Blacklist --> some product codes I want to exclude so they are placed on this sheet.
4. Client Portfolio --> Formatted list of output sheet

At the moment, I have it set up to be able to determine if the string is >=5, copy it to the "fixed" tab and then delete it from the output sheet. See below:

 Const sName As String = "Output Sheet"
    Const sCols As String = "A:D"
    Const scCol As Long = 1 ' Criteria Column
    Const shRow As Long = 1 ' Header Row
    Const sLenCriteria As String = ">=5"
    
    Const dName As String = "Fixed"
    Const dCol As String = "A"

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
     Dim sws As Worksheet: Set sws = wb.Worksheets("Output Sheet")
    If sws.AutoFilterMode Then sws.AutoFilterMode = False
    Dim slRow As Long
    With sws.Columns(sCols).Columns(scCol)
        slRow = .Cells(.Cells.Count).End(xlUp).Row
    End With
    If slRow <= shRow Then Exit Sub ' no data or just headers
    
    Dim srCount As Long: srCount = slRow - shRow + 1
    ' Source Table Range ('strg') (headers)
    Dim strg As Range: Set strg = sws.Rows(shRow).Columns(sCols).Resize(srCount)
    ' Source Data Range ('sdrg') (no headers)
    Dim sdrg As Range: Set sdrg = strg.Resize(srCount - 1).Offset(1)
    Dim scCount As Long: scCount = strg.Columns.Count
    
    Application.ScreenUpdating = False
    
    ' Source Inserted Column Range ('sicrg') (headers)
    Dim sicrg As Range: Set sicrg = strg.Columns(1).Offset(, scCount)
    sicrg.Insert Shift:=xlShiftToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Set sicrg = sicrg.Offset(, -1) ' account for 'Insert'
    ' The formula is also written to the header row which is irrelevant
    ' to the upcoming 'AutoFilter'.
    sicrg.Formula = "=LEN(" & strg.Cells(1, scCol).Address(0, 0) & ")"
    sicrg.AutoFilter 1, sLenCriteria
    
    ' Source Data Visible Range ('sdvrg') (no headers)
    Dim sdvrg As Range
    On Error Resume Next ' prevent 'No cells found' error.
        Set sdvrg = sdrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    sws.AutoFilterMode = False
    
    Dim WasBackedUp As Boolean
    
    If Not sdvrg Is Nothing Then
        
        Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
        If dws.AutoFilterMode Then dws.AutoFilterMode = False
        Dim dfCell As Range
        Set dfCell = dws.Cells(dws.Rows.Count, dCol).End(xlUp).Offset(1)
        
        sdvrg.Copy dfCell
        sdvrg.EntireRow.Delete Shift:=xlShiftUp ' resizes 'sicrg' appropriately
    
        WasBackedUp = True
    
    End If
    
    sicrg.Delete Shift:=xlShiftToLeft
    
    Application.ScreenUpdating = True

&
I have the code that matches products from the "Black List" and deletes it if it appears on the output sheet, however, I can't for the life of me get it to copy over and then delete. But I am nearly positive I could integrate this code into the above.

Dim Rng As Range
Dim f As Long
Dim lastRow As Long

' set up Matched Range
Set Rng = Worksheets("Black List").Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
Application.ScreenUpdating = False
With Worksheets("Output Sheet")
    ' get last row in column C
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

    ' always loop backwards when deleting rows
    For f = lastRow To 1 Step -1
        ' check if successful match
        If Not IsError(Application.Match(.Range("A" & f).Value, Rng, 0)) Then
            .Rows(f).Delete
        End If
    Next f
End With
Application.ScreenUpdating = True

The code is then meant to take the last value in "fixed" and SUM, and display this output in D57 on "client portfolio"

'Grabs the total from Fixed spreadsheet, inputs it into client portfolio tab
Sheets("Fixed").Select
Dim RngF As Range
    Dim cF As Range
    Set RngF = Range("C4:C" & Range("C4").End(xlDown).Row)
    Set cF = Range("C4").End(xlDown).Offset(1, 0)
    cF.Formula = "=SUM(" & RngF.Address(False, False) & ")"

Dim RngD As Range
    Dim DF As Range
    Set RngD = Range("D4:D" & Range("D4").End(xlDown).Row)
    Set DF = Range("D4").End(xlDown).Offset(1, 0)
    DF.Formula = "=SUM(" & RngD.Address(False, False) & ")"
'Dim lastCellFixed As Range
'Set lastCellFixed = Sheets("Fixed").Range("D1:D").Cells(Rows.Count, "D").End(xlUp).Row

End With

Sheets("Client Portfolio").Range("A1").Cells(57, 4).Value = DF.Value
Sheets("Client Portfolio").Range("A1").Cells(57, 8).Value = cF.Value

    
Sheets("Client Portfolio").Select

Any help is greatly appreciated,

One Stuck VBA Newbie.

 

[sijpie]

Well, there are a number of things in your code that can be improved to speed up the process. Like a 100,000 line set processed in a second. But lets start with small steps.

First the code for the blacklist. Do delete a row, use the .EntireRow property

If Not IsError(Application.WorksheetFunction.Match(.Range("A" & f).Value, Rng, 0)) Then
            .Rows(f).EntireRow.Delete

But from an efficiency point of view: assuming that the blacklist is somewhat smaller then the full list, you should loop through the blacklist and check the full list.