VBA Find match, if found, copy rows and paste in different workbook

Engalpengal · Sep 8, 2023

Hello.
I have a list of products in Col "C13:AF" In workbook "Ordre"(sheet "Ordre"), that i vant to match to "AG12".
The range for match is found in Col "AG13:AG"

There will be several hits.
I want all Matches to be copied and paste in another workbook called "Hist" (Sheet "Hist")
Range for paste destination is A9:AD
First available row

The History file will contain a year of prodused products, witch means that this list will be long as the time goes.

Under follows my attempt

VBA Code:

Sub To_Hist()

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

Set wbo = ThisWorkbook '____________________________________________________________________Workbook for search area
Set wbh = Workbooks("Hist.xlsm") '__________________________________________________________Workbook for paste area

Set wsO = wbo.Worksheets("Ordre") '_________________________________________________________Sheet for search area
Set wsH = wbh.Worksheets("Hist") '__________________________________________________________Sheet for paste area

Set srcKey = wsO.Range("AG12") '____________________________________________________________Range for Search key

Set cDest = wsOut.Range("A9:AD") '___________________________________________________________Range for Paste destination

Application.ScreenUpdating = False
For Each c In wsO.Range("AG13:AG" & wsO.Cells(Rows.Count, "AG").End(xlUp).Row).Cells '______Area for search and copy from
    If Not IsError(Application.Match(c.Value, srcKey, 0)) Then '____________________________Any match in lookup list?
        With wsO
            .Range(.Cells(c.Row, "C"), .Cells(c.Row, "AF")).Copy cDest '____________________Width of rows to copy
        End With
        Set cDest = cDest.End(xlUp).Offset(1, 0) '__________________________________________Next paste row
    End If
Next c
Application.ScreenUpdating = True
End Sub

I recive and error on following line in the program:
Set cDest = wsOut.Range("A9:AD")
Run time error 91, object variable or with block variable not set
I know this code isnt right, but i do not know how to write it correcly
WB "Ordre"

Ordre-Spor.xlsm

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

W

X

Y

Z

AA

AB

AC

AD

AE

AF

AG

AH

AI

AJ

AK

AL

AM

AN

AO

AP

AQ

AR

AS

AT

AU

AV

10

Dato for utført prosess

Prosesser

11

Status

Ordre nr

Salgsordre dato

Forv.fors.dato

Produkt nr

Produktbeskrivelse

Pos

Lengde, mm

Bredde, mm

Ekstra info

Farge RAL

Ant

Kunde nr

Kunde navn

Ordre ans

PL, dato

PLM, dato

OV, dato

PR, dato

SKS, dato

SK, dato

SKVD, dato

MA, dato

LE, dato

MV, dato

VA, dato

BSS, dato

CS, dato

CSF, dato

LA, dato

PiU, dato

PL

PLM

OV

PR

SKS

SK

SKVD

MA

LE

MV

VA

BS-S

CS-S

CS-F

LA

12

-

1

-

13

964841

31.05.2023

05.08.2023

11051612132

Skilt nr 516VH LS R-kl 3 Tosidig H=hldr Gangfelt

1

778899

Hedlund Bil

MM

00.01.1900

#######

00.01.1900

14

964841

31.05.2023

05.08.2023

11052200131

Skilt nr 522 R-kl 3 H=klmr Gang- og sykkelveg

Skjæring

1

778899

Hedlund Bil

MM

00.01.1900

#######

00.01.1900

15

964841

31.05.2023

05.08.2023

12010808200

Skilt R.kl 1 H=klmr - Møteplass ved brann/evakuering

Gul-grønn fluor.

2

778899

Hedlund Bil

MM

00.01.1900

#######

00.01.1900

16

964841

31.05.2023

05.08.2023

41690000310

Underskilt for foldeskilt, Nøytrale underskilt gul

2

778899

Hedlund Bil

MM

00.01.1900

#######

00.01.1900

17

965357

01.06.2023

08.08.2023

11072902122

Skilt nr 729 R-kl 2 Gatenavn tosidig (10 bokst. TH=70mm)

1

123456

NAF Fjellstuen

TR

00.01.1900

18

965640

02.06.2023

08.08.2023

21020089400

Stolpe, 89 mm/4,0 m

6012

1

958647

Melund Trafikk

KR

00.01.1900

19

965640

02.06.2023

10.08.2023

21970000500

Omstillingskostnad, lakkering

1

958647

Melund Trafikk

KR

00.01.1900

20

965640

02.06.2023

10.08.2023

91010101000

Frakt totalt

1

123456

NAF Fjellstuen

TR

00.01.1900

21

854463

23.04.2023

11.08.2023

11040210111

Skilt nr 402.1 LS R-kl 1 H=klmr Påbudt kjøreretning

1

966322

Finsnes Autobane

IL

00.01.1900

22

854463

23.04.2023

11.08.2023

21010060250

Stolpe, 60 mm/2,5 m

1

966322

Finsnes Autobane

IL

00.01.1900

01.09.2023

00.01.1900

1

PL

x

V

23

854463

23.04.2023

11.08.2023

21127060000

Klammer rett, alu., 60 mm, ensidig kompl. m/skrue

2

966322

Finsnes Autobane

IL

00.01.1900

01.09.2023

00.01.1900

1

x

V

Ordre

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
AV13:AV3000	Cell Value	beginning with "LA"	text	NO
AV13:AV3000	Cell Value	="V"	text	NO
AN13:AN3000	Cell Value	="V"	text	NO
AN13:AN3000	Cell Value	beginning with "SK"	text	NO
AM13:AM3000	Cell Value	beginning with "SK"	text	NO
AM13:AM3000	Cell Value	="V"	text	NO
AL13:AL3000	Cell Value	beginning with "SK"	text	NO
AL13:AL3000	Cell Value	="V"	text	NO
AK13:AK3000	Cell Value	="V"	text	NO
AK13:AK3000	Cell Value	beginning with "PR"	text	NO
AJ13:AJ5000	Cell Value	="Nytt prod"	text	NO
AJ13:AJ5000	Cell Value	="V"	text	NO
AJ13:AJ5000	Cell Value	beginning with "OV"	text	NO
AI13:AI3000	Cell Value	="V"	text	NO
AH13:AH3000	Cell Value	="Nytt prod"	text	NO
E13:E2000	Dates Occurring	yesterday	text	NO
E13:E2000	Dates Occurring	today	text	NO
E13:E2000	Dates Occurring	tomorrow	text	NO
E13:E2000	Dates Occurring	last 7 days	text	NO
E13:E2000	Dates Occurring	this week	text	NO
E13:E2000	Dates Occurring	last month	text	NO
E13:E2000	Dates Occurring	last week	text	NO
AH13:AH3000	Cell Value	="V"	text	NO
Q13:AF1048576	Cell Value	>1	text	NO
Q13:AF1048576	Cell Value	>0	text	NO
AI13:AI3000	Cell Value	beginning with "PLM"	text	NO
AH13:AH3000	Cell Value	beginning with "PL"	text	NO
B13:B26051	Cell Value	<0	text	NO
B13:B26051	Cell Value	beginning with "PL"	text	NO
B13:B26051	Cell Value	beginning with "PR"	text	NO
B13:B26051	Cell Value	beginning with "OV"	text	NO
B13:B26051	Cell Value	beginning with "SK"	text	NO
B13:B26051	Cell Value	beginning with "LA"	text	NO

WB "Hist"

Hist.xlsm

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

W

X

Y

Z

AA

AB

AC

AD

AE

AF

7

Ordre nr

Salgsordre dato

Forv.fors.dato

Produkt nr

Produktbeskrivelse

Pos

Lengde, mm

Bredde, mm

Ekstra info

Farge RAL

Ant

Kunde nr

Kunde navn

Ordre ans

PL, dato

PLM, dato

OV, dato

PR, dato

SKS, dato

SK, dato

SKVD, dato

MA, dato

LE, dato

MV, dato

VA, dato

BSS, dato

CS, dato

CSF, dato

LA, dato

PiU, dato

Ledetid, dager

8

-

9

112233

12.04.2023

14.08.2023

11011000243

Skilt nr 110 MS R-kl 3 G/GR H=nøkkel Vegarbeid

flgkjdghf

1

34100

Karmøy Kommune

ØK

00.01.1900

#######

00.01.1900

#######

00.01.1900

#######

00.01.1900

10

112233

12.04.2023

14.08.2023

11011000331

Skilt nr 110 SS R-kl 3 G/GR H=klmr Vegarbeid

1

25719

Mesta AS

MN

00.01.1900

#######

00.01.1900

#######

00.01.1900

#######

00.01.1900

11

112233

12.04.2023

14.08.2023

11011000531

Skilt nr 110 MS R-kl 3 G/GR m/bakstøtte Vegarbeid

5778

2

25719

Mesta AS

BUR

00.01.1900

#######

00.01.1900

#######

00.01.1900

#######

00.01.1900

12

665544

21.08.2023

04.09.2023

11072909212

Skilt nr 729 R-kl 1 Gatenavn tosidig (13 bokst. TH=105mm)

1900

380

Skjæring

9999

2

777777

Bærum Kommune

RR

00.01.1900

#######

00.01.1900

#######

00.01.1900

13

14

15

16

17

18

19

Hist

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
C12	Dates Occurring	yesterday	text	NO
C12	Dates Occurring	today	text	NO
C12	Dates Occurring	tomorrow	text	NO
C12	Dates Occurring	last 7 days	text	NO
C12	Dates Occurring	this week	text	NO
C12	Dates Occurring	last month	text	NO
C12	Dates Occurring	last week	text	NO
O12:AD12	Cell Value	>1	text	NO
O12:AD12	Cell Value	>0	text	NO
C11	Dates Occurring	yesterday	text	NO
C11	Dates Occurring	today	text	NO
C11	Dates Occurring	tomorrow	text	NO
C11	Dates Occurring	last 7 days	text	NO
C11	Dates Occurring	this week	text	NO
C11	Dates Occurring	last month	text	NO
C11	Dates Occurring	last week	text	NO
O11:AD11	Cell Value	>1	text	NO
O11:AD11	Cell Value	>0	text	NO
C10	Dates Occurring	yesterday	text	NO
C10	Dates Occurring	today	text	NO
C10	Dates Occurring	tomorrow	text	NO
C10	Dates Occurring	last 7 days	text	NO
C10	Dates Occurring	this week	text	NO
C10	Dates Occurring	last month	text	NO
C10	Dates Occurring	last week	text	NO
O10:AD10	Cell Value	>1	text	NO
O10:AD10	Cell Value	>0	text	NO
C9	Dates Occurring	yesterday	text	NO
C9	Dates Occurring	today	text	NO
C9	Dates Occurring	tomorrow	text	NO
C9	Dates Occurring	last 7 days	text	NO
C9	Dates Occurring	this week	text	NO
C9	Dates Occurring	last month	text	NO
C9	Dates Occurring	last week	text	NO
O9:AD9	Cell Value	>1	text	NO
O9:AD9	Cell Value	>0	text	NO
C13:C501	Dates Occurring	yesterday	text	NO
C13:C501	Dates Occurring	today	text	NO
C13:C501	Dates Occurring	tomorrow	text	NO
C13:C501	Dates Occurring	last 7 days	text	NO
C13:C501	Dates Occurring	this week	text	NO
C13:C501	Dates Occurring	last month	text	NO
C13:C501	Dates Occurring	last week	text	NO
O13:AD501	Cell Value	>1	text	NO
O13:AD501	Cell Value	>0	text	NO

MARK858 · Sep 8, 2023

You only need the first cell in the range for the paste so you only need

VBA Code:

Set cDest = wsOut.Range("A9")

and

VBA Code:

Set cDest = cDest.End(xlUp).Offset(1, 0)

change to

VBA Code:

Set cDest = cDest.Offset(1, 0)

I also can't see you defining the sheet anywhere for wsOut, are you sure it shouldn't be wsH

Engalpengal · Sep 8, 2023

Thanks Mark you have good eyes.
The program finds the correct lines, but when pasting in "Hist", it doesn't go to the first available row, it overwrites the first line in the specified range

MARK858 · Sep 8, 2023

Is there anything in A8 of sheet Hist? and are the cells below A8 all blank?

MARK858 · Sep 8, 2023

Going by your XL2BB try the code below (untested)

VBA Code:

Sub To_Hist()

Dim c As Range, wbo As Workbook, wbh As Workbook
Dim wsO As Worksheet, wsH As Worksheet, srcKey As Range

Set wbo = ThisWorkbook '____________________________________________________________________Workbook for search area
Set wbh = Workbooks("Hist.xlsm") '__________________________________________________________Workbook for paste area

Set wsO = wbo.Worksheets("Ordre") '_________________________________________________________Sheet for search area
Set wsH = wbh.Worksheets("Hist") '__________________________________________________________Sheet for paste area

Set srcKey = wsO.Range("AG12") '____________________________________________________________Range for Search key


Application.ScreenUpdating = False

For Each c In wsO.Range("AG13:AG" & wsO.Cells(Rows.Count, "AG").End(xlUp).Row).Cells '______Area for search and copy from
   
    If Not IsError(Application.Match(c.Value, srcKey, 0)) Then '____________________________Any match in lookup list?
        With wsO
            .Range(.Cells(c.Row, "C"), .Cells(c.Row, "AF")).Copy wsH.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        End With
    End If
   
Next c

Application.ScreenUpdating = True
End Sub

Engalpengal · Sep 8, 2023

Thank You Mark for all your help

MARK858 · Sep 8, 2023

You're welcome

VBA Find match, if found, copy rows and paste in different workbook

Engalpengal

New Member

Excel Facts

MARK858

MrExcel MVP

Engalpengal

New Member

MARK858

MrExcel MVP

MARK858

MrExcel MVP

Engalpengal

New Member

MARK858

MrExcel MVP

Similar threads

Forum statistics

Share this page

VBA Find match, if found, copy rows and paste in different workbook

Engalpengal

New Member

Excel Facts

MARK858

MrExcel MVP

Engalpengal

New Member

MARK858

MrExcel MVP

MARK858

MrExcel MVP

Engalpengal

New Member

MARK858

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock