Loop through a row, check if certain cells are empty, if not go to the page referenced in the cell and carry out some copying/pasting

Question

I'm in need of some assistance to condense my code. I've created quite a large spreadsheet for orders and invoices for my company. With its size and the amount of code, it's pretty slow in execution.

The coding I would like some help with should first of all copy cells in column A & B of the current active row then look through a row, through use of the row with column "A" being the current active cell. It needs to find a product which references to the products stock page, the cell will start at an offset of 13, it will activate the page of the product, and paste the copied cells to a table staring at range "F4", but it then needs to look though to see if there's another product on the orders page which will then be an offset of 2 each time. Below is my current code, any insight would be extremely helpful

If Not neworder.cbotype.Value = "L-Wholesale-Abbas" Then
    If Not neworder.cbotype.Value = "V-Wholesale-Abbas" Then
    '(1)
    Sheets("Orders").Select
    ActiveCell.Select
    ActiveCell.Resize(1, 2).Select
    Selection.Copy
    ActiveCell.Offset(0, 13).Select

    Worksheets(ActiveCell.Value).Activate

    lRow = ActiveSheet.Range("f4").CurrentRegion.Rows.Count

    With ActiveSheet.Range("f4")    
        Range("f4").Select
        Selection.End(xlDown).Select
        .Offset(lRow, 0).Select
        Selection.PasteSpecial
        Range("h2:i2").Copy
        .Offset(lRow, 2).PasteSpecial    
    End With

    '(2)
    On Error Resume Next
    Sheets("Orders").Select
    ActiveCell.Select
    If Not IsEmpty(ActiveCell.Offset(0, 2)) Then
        ActiveCell.Offset(0, -13).Select
        ActiveCell.Resize(1, 2).Select
        Selection.Copy
        ActiveCell.Offset(0, 15).Select

        Worksheets(ActiveCell.Value).Activate

        lRow2 = ActiveSheet.Range("f4").CurrentRegion.Rows.Count

        With ActiveSheet.Range("f4")    
            Range("f4").Select
            Selection.End(xlDown).Select
            .Offset(lRow2, 0).Select
            Selection.PasteSpecial
            Range("h2:i2").Copy
            .Offset(lRow2, 2).PasteSpecial    
        End With
    Else
End If

It then continues with (2) repeating up to (50)

Below is a row from the orders page where this code works, i've put an "x" in two empty columns, the cells my code is looking for are the ones at the end, there is item quantity then item reference repeated 50 times

    1-Jun   VK-LG-3224_1    Dropship    Bellezza scarf  rahima begum    Seller   £7.00  PayPal   £6.56  x   x   1   VIVK-N-NP-203   1   VIVK-N-NP-197

Step by Step: 1) copy cells A & B in last row 2) open sheet name in column N 3) paste in last row from table starting F4 4) go back to orders sheet 5) copy cells A & B from same row as earlier 6) open sheet name in column P 7) paste in last row from table starting F4

This continues along the same row, moving along two columns at a time until the last column which is DH

Welcome to Stackoverflow. Could you provide a snap shot of the initial data and how you want the data to be processed. This will help to understand what you are trying to do. What you are trying to do is achievable. — Jean-Pierre Oosthuizen, Sep 18 '17 at 12:15
[Avoid `Select` whenever possible](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). Show the whole procedure. Indent your code to improve readability - [Rubberduck](http://www.rubberduckvba.com/) will help you with this and many more code issues. `On Error Resume Next` is just asking for trouble - it's sweeping any errors under the rug pretending they don't exist - it will only lead to tears in the future. — FreeMan, Sep 18 '17 at 12:47
I am still struggling to see / understand what you want. Can you give a step by step in your question. something like search For each row in orders sheet copy cells A and B and then paste the data into the sheet name which is in column N and then continue on the next row in order sheet — Jean-Pierre Oosthuizen, Sep 19 '17 at 08:26
@Jean-PierreOosthuizen That is basically it but i will post a step by step as requested — C.Madle, Sep 19 '17 at 09:23

score 1 · Answer 1 · answered Sep 18 '17 at 12:12

1

please in the beginning of your code add the below:

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

and at the end:

Application.Calculation = xlCalculationAuto
Application.ScreenUpdating = True

answered Sep 18 '17 at 12:12

Nikolaos Polygenis

591
7
13

score 1 · Answer 2 · answered Sep 18 '17 at 12:17

Do NOT use select! Define a range variable and refer to that

Your code

  ActiveCell.Select
  ActiveCell.Resize(1, 2).Select
  Selection.Copy

Requires Excel to discover the activecell 2 times. Instead

 DIm r as Range
 Set r = Activecell
 r.resize(1,2)
 r.copy

Then at the beginning of your code use

 Application.ScreenUpdating = False
 Application.Calculation = XLCalculateManual
 Application.EnableEvents = False

And then at the end of your code use

 Application.ScreenUpdating = true
 Application.Calculation = XLCalculateAutomatic
 Application.EnableEvents = true

Thank you, i already have those at the beginning and end of the main code, as this part of code is pulled using the `call` funtion — C.Madle, Sep 18 '17 at 14:58

Jean-Pierre Oosthuizen · Accepted Answer · 2017-09-19T12:38:57.847

The code below will do the following:

Copy the text from the A and B cells in the last row of the Order Sheet
It then looks in every second cell in that row from column N to Column N +50 for a sheet name and then pastes the values from OrderSheet Cells A and B.

Credit Rory to for the function to check the validity of the sheet name. Taken from this answer

    Option Explicit

    Sub SearchAndCopy()

        Dim LastRowOrderSheet As Long
        Dim OrderSheetColRef As Long
        Dim OrderSheet As Worksheet
        Dim LastRowCopyToSheet As Long
        Dim OrderSheetStartCol As Long
        Dim OrderCopyRange As Range
        Dim CopyToSheet As Worksheet
        Dim CopyToSheetName As String

        Set OrderSheet = ThisWorkbook.Sheets("Orders")

        LastRowOrderSheet = OrderSheet.Cells(OrderSheet.Rows.Count, "A").End(xlUp).Row

        OrderSheetStartCol = 14

        With OrderSheet
            Set OrderCopyRange = .Range(.Cells(1, 1), .Cells(1, 2))
        End With

        For OrderSheetColRef = OrderSheetStartCol To OrderSheetStartCol + 50 Step 2

            'Trim to remove any possibly unwanted blank spaces before or after the name
            CopyToSheetName = Trim(OrderSheet.Cells(LastRowOrderSheet, OrderSheetColRef).Value)

            'Ending Loop if there is no name in CopyToSheetName
            If Trim(CopyToSheetName) = "" Then
                Exit For
            End If

            'If the SheetName returns back False then the error message appears
            If Not WorksheetExists(CopyToSheetName) Then
                MsgBox "Sheet: " & CopyToSheetName & " does not exisit." & vbCr & vbCr & _
                      "Check Order sheet:" & vbCr & _
                      "Row: " & LastRowOrderSheet & vbCr & _
                      "Column: " & OrderSheetColRef
                End
            End If
            Set CopyToSheet = ThisWorkbook.Sheets(CopyToSheetName)

            With CopyToSheet

                LastRowCopyToSheet = .Cells(.Rows.Count, "F").End(xlUp).Row
                                                '+1 because the lastrow plus 1 is the next empty row
                .Range(.Cells(LastRowCopyToSheet + 1, "F"), _
                       .Cells(LastRowCopyToSheet + 1, "G")) = OrderCopyRange.Value

                'Copy formulas from CopyTSheet H2:I2 to the adjacent cells on right of new data in CopyToSheet
                .Range("H2:I2").Copy .Range(.Cells(LastRowCopyToSheet + 1, "H"), _
                                            .Cells(LastRowCopyToSheet + 1, "I"))

            End With

        Next OrderSheetColRef

    End Sub

Thank you!! This is working perfectly. There is just one thing i need to add that i thought would be simple to input but just isn't working for me... when on `CopyToSheet` i need it to copy formulas from h2:i2 and then paste next to that data just pasted in f & g — C.Madle, Sep 19 '17 at 11:02
when on CopyToSheet i need it to copy formulas from h2:i2 and then paste next to that data just pasted in f & g — C.Madle, Sep 19 '17 at 11:49
@C.Madle are you wanting to copy `CopyToSheet.Range("H2:I2").Formula` to the the right hand side of the newly pasted data in the `CopyToSheet` — Jean-Pierre Oosthuizen, Sep 19 '17 at 11:54
Ok for some reason its not working with the validation element, to be honest i dont need this as the Sheets are made using a macro that creates a page and a list and therefore the reference entered should never be incorrect from the page name, however i do need it to stop looking for sheet names if the cell turns up empty. Also i changed `OrderCopyRange = .Range(.Cells(1, 1), .Cells(1, 2))` to `OrderCopyRange = .Range(.Cells(LastRowOrderSheet, 1), .Cells(LastRowOrderSheet, 2))` as it was copying the headers from the table on that sheet — C.Madle, Sep 19 '17 at 12:25
Is there a way i can get it to stop looping if there isn't a sheetname to look for?? — C.Madle, Sep 19 '17 at 12:31
@C.Madle the code will continue for 18 loops which is `Column N` plus 50 with skipping 2. I will update my answer to check if the `CEll` is blank before continuing with the loop. — Jean-Pierre Oosthuizen, Sep 19 '17 at 12:36

Loop through a row, check if certain cells are empty, if not go to the page referenced in the cell and carry out some copying/pasting

3 Answers3