VBA - Find match from another workbook, with multiple criterias, and paste in first awailable row

[Engalpengal]

Hello again
First of all, I want to use this opportunity to thank you all here Mr. Excel for the help I have received from you in previous posts.
The work you have put in to it has been invaluable.
I have learned so much, but still have a lot more left to learn
My main goal is to make a process planning system

So the next obstacle is marked in blue:
Sub Copy_ord_fromPL()

Dim oRdre As Variant
Dim pL As Variant

Dim cR1 As String '-------------------------------------------------- Text only
Dim copyFr As Variant '--------------------------------------------- Numbers and text
Dim pDest As Variant '---------------------------------------------- Numbers and text

Set oRdre = Workbooks("Ordre-Spor.xlsm").Sheets("Ordre") '---- Set Workbook for search area
Set pL = ThisWorkbook.Sheets("Plate_copy.xlsm") '--------------- Set Workbook for paste area

Set cRl = oRdre.Range("AK13:BC5000") '--------------------------- Set area for Criteria
Set copyFr = oRdre.Range("C13:P25000") '------------------------ Set search and copy range/area
Set pDest = pL.Range("C67:P5000") '------------------------------ Set paste range/area

Set mPL = oRdre.Range("AK11:AO11") '-------------------------- Set area for key cells, to match in range "kR1area"

Application.ScreenUpdating = False

Action:
Search in "cR1" for rows that match with info given in "mPL" (minimum one col match)
If true (can be more than one rowmatch), copy value C:P
Paste in area "pDest", first available row

Application.ScreenUpdating = True
End Sub


Explanation pictures

Pic 1 - "oRdre.jpg"
Here is a list of products. Further down the row you will find a "process-descriprion" (see pic 2).

Pic 2 - "cR1-and-mPL.jpg"
Cells AK11:AT11 is a process description
Every product line has a separately process setup
0 means that the product isnt suppose to go through that spesific process, and therefore the product shall not be copied
If the product should go through a sesofic process, the column for that spesific prosess will be marked with the process name. This product must be copied.
If the product has been through that process, the column is marked with a green "v", and therefore the product shall not be copied

Pic 3 - "pL.jpg"
Paste area for products that are ready for process starting with "PL"


Hope that this explanation is understandable and that it is possible to program

 

[Engalpengal]

I have found many simular problems online, where a vba program has been published that has solved the problem.
But my lack of knowledge makes me unable to adapt these macros to my situation.
And i allways end up with a mess.
So i tried to start from scratch, but that was no success either.
Hope you guys can help and maby explane how you set it up?

 

[Engalpengal]

I think i have found a solution.
Thx for your time

 

[Peter_SSs]

Good to hear you found a solution.
If you would like to post the solution then it is perfectly fine to mark your post as the solution to help future readers. Otherwise, please do not mark a post that doesn't contain a solution.

 

[Engalpengal]

Hi Peter
I understand and I apologize.
The solution generates no error messages, but then nothing happens when I run the program either.
Maybe you guys can see where wrongs lie?
Im struggling with thinking backwards so it may be I switch between where the info should be copied from and where it should be pasted to....

Sub Copy_f_Ordre()

Dim c As Range, wbo As Workbook, wbp As Workbook, SchOO As Worksheet, SchP As Worksheet
Dim pDest As Range, Key As Range

Set wbp = ThisWorkbook
Set wbo = Workbooks("Ordre-Spor.xlsm")
Set SchOO = wbo.Worksheets("Ordre")
Set SchP = wbp.Worksheets("Plate")

Set Key = SchOO.Range("AK11")
SchOO.Rows(1).Copy SchP.Rows(1)
Set pDest = SchP.Range("C67:P67")

Application.ScreenUpdating = False
For Each c In SchOO.Range("C13:P" & SchOO.Cells(Rows.Count, "AK").End(xlUp).Row).Cells
    If Not IsError(Application.Match(c.Value, Key, 0)) Then
        With SchP
            .Range(.Cells(c.Row, "C"), .Cells(c.Row, "P")).Copy pDest
        End With
        Set pDest = pDest.Offset(1)
    End If
Next c
Application.ScreenUpdating = True

End Sub

I want to copy product lines form:
Workbooks("Ordre-Spor.xlsm").Sheets("Ordre").Range("C13:P25000")
To:
ThisWorkbook Sheets("Plate").Range("C67:P") First available row.

But i vant only product lines that has a match in column "AK"

The Matchkey is found in:
Workbooks("Ordre-Spor.xlsm").Sheets("Ordre").Range("AK11")

 

[Engalpengal]

Hi all.
I`ve started "fresh" with a new model.
When i run it, i receive "runtime error 1004" (marked in red).
What am I doing wrong?
Source: Excel VBA: Copy Row If Cell Value Matches (2 Methods)

Sub Copy_f_Ordre()

'Declare variables
Dim DataRg As Range
Dim DataCell As Range
Dim P As Long
Dim J As Long
Dim I As Long

'Set variables
P = Workbooks("Ordre-Spor.xlsm").Sheets("Ordre").UsedRange.Rows.Count
Q = Worksheets("Plate").UsedRange.Rows.Count

'Type If condition to relate the variables I and Q
If I = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Plate").UsedRange) = 0 Then Q = 0
End If

'Set range for Ordre
Set DataRg = Workbooks("Ordre-Spor.xlsm").Sheets("Ordre").Range("AK13:AK10000" & P)
On Error Resume Next
Application.ScreenUpdating = False

'Apply the For loop
For I = 1 To DataRg.Count

'Set Condition for Search Key
Set Key = Workbooks("Ordre-Spor.xlsm").Sheets("Ordre").Range("AK11")
If CStr(DataRg(I).Value) = Key Then


DataRg(I).EntireRow.Copy Destination:=Worksheets("Plate").Range("C67" & Q + 1)
Q = Q + 1
End If
Next

Application.ScreenUpdating = True

End Sub

 

[Engalpengal]

Finally I have created a program that does something.
But there are some errors that I can't solve.
Among other things, it copies with cell formatting, and it fills the last match in remaining rows in the pasting range.

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

Sub Copy_f_Ordre()
Set wb = ThisWorkbook
Set wbo = Workbooks("Ordre-Spor.xlsm")
Set wsSrc = wbo.Worksheets("Ordre")
Set wsOut = wb.Worksheets("Plate")
Set wsTrans = wbo.Worksheets("Ordre")
Set rngList = wsTrans.Range("AH11")
wsSrc.Rows(1).Copy wsOut.Rows(1)
Set cDest = wsOut.Range("B67:O500")

Application.ScreenUpdating = False
For Each c In wsSrc.Range("AH13:AH" & wsSrc.Cells(Rows.Count, "AH").End(xlUp).Row).Cells ' Area for search and copy from
If Not IsError(Application.Match(c.Value, rngList, 0)) Then
With wsSrc
.Range(.Cells(c.Row, "C"), .Cells(c.Row, "P")).Copy cDest
End With
Set cDest = cDest.Offset(1)
End If
Next c
Application.ScreenUpdating = True

 

[Engalpengal]

It helped to Clear range "cDest" before running the program.
I added an sub to clear duplicates.

 

[Peter_SSs]

When posting vba code in the forum, please use the available code tags. It makes your code much easier to read/debug & copy. My signature block below has more details. I was hoping you may have noticed that previously I added the tags for you in post #5.

 

[Engalpengal]

Like this Peter?
The program isnt perfect, but it works for now

Sub PL_Oppdat_ordre()

unprotect
unprotectO
Clear

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 wbo = Workbooks("Ordre-Spor.xlsm") '___________________________________________________workbook for search area
Set wsSrc = wbo.Worksheets("Ordre") '______________________________________________________Sheet for search area
Set wsOut = wb.Worksheets("PL") '__________________________________________________________Sheet for paste destination
Set wsTrans = wbo.Worksheets("Ordre") '____________________________________________________Sheet for search key
Set rngList = wsTrans.Range("AH11") '______________________________________________________Range for Search key

wsSrc.Rows(1).Copy wsOut.Rows(1)
Set cDest = wsOut.Range("B49:O500") '______________________________________________________Range for Paste destination

Application.ScreenUpdating = False
For Each c In wsSrc.Range("AH13:AH" & wsSrc.Cells(Rows.Count, "AH").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, "C"), .Cells(c.Row, "O")).Copy cDest
        End With
        Set cDest = cDest.Offset(1) '______________________________________________________Next paste row
    End If
Next c
Application.ScreenUpdating = True

protect
protectO
End Sub

Sub unprotect()
ActiveSheet.unprotect "1234"
End Sub

Sub protect()
ActiveSheet.protect "1234"
End Sub

Sub unprotectO()
Set wbo = Workbooks("Ordre-Spor.xlsm")
wbo.ActiveSheet.unprotect "1234"
End Sub

Sub protectO()
Set wbo = Workbooks("Ordre-Spor.xlsm")
wbo.ActiveSheet.protect "1234"
End Sub

Sub Clear()
Range("B49:O10000").ClearContents
End Sub