VBA macro - Match to a single cell, copy multiple hits (with rows) and paste in first available row in a different sheet

Engalpengal

New Member
Joined
May 10, 2023
Messages
43
Office Version
  1. 365
Platform
  1. Windows
Hi all.
I am new to VBA programming but am in progress to learn how to use this wonderful tool.
Unfortunately, I cannot share the document due to its contents and that the information belongs to the company I work for. But I will try to explain what I am working on.

I have a long list of customer orders. Based on this list, I want to be able to extract a specific order. An order can have several product lines in the customer order list, but each product line refers to a given order no. Order no is shown in column B
Order list -> Sheets(«Customer order»).Range(«B24:M1000») - The product lines contain both numbers, dates and text, with and without formulas.

In another sheet in the same file, we enter a desired order number (this is entered manually in a given cell),
Order number -> Sheets("LA").Range("F6")
which retrieves all the product lines linked to the given order no for review.

When the person in question has reviewed the order, I want him or her to be able to, by pressing a button, copy (only value, text and numbers, not formatting or formulas) all order lines in the order list that match the order number in given cell -> Sheets("LA").Range("F6").

These order lines must now be pasted into a list for order history, first available row.

Order history -> Sheets("LA").Range("P:AA") - First row is P5:AA5
I have tried countless compositions I have found online but have not quite managed to adapt them to my needs.

The last one I have tried is the following:

Sub Ferdig_LASen()
Dim c As Range, wsSrc As Worksheet, wsOut As Worksheet, wb As Workbook
Dim cDest As Range, wsTrans As Worksheet, rngList As Range

Set wb = ThisWorkbook
Set wsSrc = wb.Worksheets("Kundeordre") 'orderlist, search area
Set wsOut = wb.Worksheets("LA") 'Paste area
Set wsTrans = wb.Worksheets("LA")
Set rngList = wsTrans.Range("F6") 'order no, search key
wsSrc.Rows(1).Copy wsOut.Rows(1)
Set cDest = wsOut.Range("P5:AA5") 'first paste destination

Application.ScreenUpdating = False
For Each c In wsSrc.Range("B24:B" & wsSrc.Cells(Rows.Count, "B").End(xlUp).Row).Cells
If Not IsError(Application.Match(c.Value, rngList, 0)) Then 'any match in lookup list?
c.EntireRow.Copy cDest
Set cDest = cDest.Offset(1) 'next paste row
End If
Next c
Application.ScreenUpdating = True
End Sub

There are probably many errors in this programming that I cannot see myself, so I need your expertise.
Hope my explanation and situation is understandable, and feel free to ask questions give feedback.
Thank you for your attention.
Look forward to your suggestions
 

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying
I forgot to mention that i know how to set up buttons with macro functions
Hope to hear from some of you soon :)
 
Upvote 0
Do any of you have a tip about a site where I can find the information I need to solve my macro problem?
 
Upvote 0
In another sheet in the same file, we enter a desired order number (this is entered manually in a given cell),
Order number -> Sheets("LA").Range("F6")
which retrieves all the product lines linked to the given order no for review.
Do you have this part working ?
You have MS 365 so this part can be done but just putting a Filter function at F6.
 
Upvote 0
Thank you for your inquiry Alex
I get a Run time error '1004' on this part of the macro (marked in red):

Application.ScreenUpdating = False
For Each c In wsSrc.Range("B24:M" & wsSrc.Cells(Rows.Count, "B").End(xlUp).Row).Cells
If Not IsError(Application.Match(c.Value, rngList, 0)) Then 'any match in lookup list?
c.EntireRow.Copy cDest
Set cDest = cDest.Offset(1) 'next paste row
End If
Next c
Application.ScreenUpdating = True


The message is as follows (It is translated from another language, so it is conceivable that it may not be exactly the same message as in the English version):

"You cannot paste this here because the copy area and the paste area are not the same size
Just select a cell in the pasting area or an area of the same size and try pasting again"

I understand that there is a miss match between the area I have specified, but I still don't quite understand how to set/code it correctly.
 
Upvote 0
You can't copy an Entire row to
Set cDest = wsOut.Range("P5:AA5") 'first paste destination

Try replacing you EntireRow copy line with this one:
VBA Code:
            wsSrc.Range("B24:M" & c.Row).Copy cDest

PS: Your use of Match doesn't make sense. Like your comment says "any match in lookup list" but your rngList is not a list but a single cell
ie Set rngList = wsTrans.Range("F6")
 
Upvote 0
Thx Alex
I have done the changes you recommended, but perhaps i misunderstand you?
I still get the same Error
It may be that I am mixing up what is the search page and what is the paste page
When it comes to programming, it's hard to think backwards
Under follows updated macro

Sub Ferdig_LASen()

Dim c As Range, wsSrc As Worksheet, wsOut As Worksheet, wb As Workbook
Dim cDest As Range, wsTrans As Worksheet, rngList As Range

Set wb = ThisWorkbook
Set wsSrc = wb.Worksheets("Ordre") 'Sheet for search area
Set wsOut = wb.Worksheets("LA") 'Sheet for paste destination

Set wsTrans = wb.Worksheets("LA") 'Sheet search key
Set rngList = wsTrans.Range("F6") 'search key
wsSrc.Rows(1).Copy wsOut.Rows(1)
Set cDest = wsOut.Range("P:AA") 'Paste destination

Application.ScreenUpdating = False
For Each c In wsSrc.Range("B24:M" & wsSrc.Cells(Rows.Count, "B").End(xlUp).Row).Cells ' Area for search and copy from
If Not IsError(Application.Match(c.Value, rngList, 0)) Then 'any match in lookup list?
c.EntireRow.Copy cDest
Set cDest = cDest.Offset(1) 'next paste row
End If
Next c
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Give the below code a try:

PS: I have not changed this but since in
If Not IsError(Application.Match(c.Value, rngList, 0)) Then
rngList is a single cell (F6) you could just as easily have used
If UCase(c.Value) = UCase(rngList) Then

I suspect the Match line is not doing what you are meaning for it to do.

Rich (BB code):
Sub Ferdig_LASen_v02_Mod01()

Dim c As Range, wsSrc As Worksheet, wsOut As Worksheet, wb As Workbook
Dim cDest As Range, wsTrans As Worksheet, rngList As Range

Set wb = ThisWorkbook
Set wsSrc = wb.Worksheets("Ordre") 'Sheet for search area
Set wsOut = wb.Worksheets("LA") 'Sheet for paste destination

Set wsTrans = wb.Worksheets("LA") 'Sheet search key
Set rngList = wsTrans.Range("F6") 'search key
wsSrc.Rows(1).Copy wsOut.Rows(1)
Set cDest = wsOut.Range("P5:AA5") 'Paste destination

Application.ScreenUpdating = False
For Each c In wsSrc.Range("B24:M" & wsSrc.Cells(Rows.Count, "B").End(xlUp).Row).Cells ' Area for search and copy from
    If Not IsError(Application.Match(c.Value, rngList, 0)) Then 'any match in lookup list?
        With wsSrc
            .Range(.Cells(c.Row, "B"), .Cells(c.Row, "M")).Copy cDest
        End With
        Set cDest = cDest.Offset(1) 'next paste row
    End If
Next c
Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0
Solution
Sorry for the very late response, it's been a lot at work.
Alex you are absolutely amazing!
I could kiss you ten times over!!!
Thank you so much, you have no idea how much this means to me.
 
Upvote 0
Just one question Alex.
If i wish to change the paste destination to another sheet. How would you write the command?

Set cDest = wsOut.Range("P5:AA5") 'Paste destination
New destination follows
Sheets("Ordre").Range("Z5:AK5") - first available row
 
Upvote 0

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

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
Back
Top