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

John_C4439

New Member
Joined
Jan 27, 2022
Messages
1
Office Version
  1. 365
Platform
  1. Windows
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:
VBA Code:
 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.

VBA Code:
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"

VBA Code:
'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.
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"

sijpie

Well-known Member
Joined
Nov 1, 2008
Messages
3,986
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
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
VBA Code:
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.
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,167,159
Messages
5,852,434
Members
431,507
Latest member
gatobarbieri

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top