Copie to

[brankscaffold]

I got this one off the net, but I can't get it to work quite right.

now only 2 lines are copied and always the same

Sub rowcopy()
Const FirstRow = 2
Dim rij As Long
Dim n As Long
Dim src As Worksheet
Dim trg As Worksheet
Dim SrcRow As Long
Dim lastRow As Long
                        Set src = Sheets("Ridon 22")
                        Set trg = Sheets("Asindo 22")
                                                        Application.ScreenUpdating = False

                        rij = trg.[A65536].End(xlUp).Row

For n = 5 To Blad1.[A65536].End(xlUp).Row
If Cells(n, "AE").Value = "Asindo" Then
Range(Cells(n, "A"), Cells(n, "AZ")).Copy
trg.Cells(rij, "A").PasteSpecial

 

[Alex Blakenburg]

Rather than waiting for your response and most likely totally redesigning the code, here is a modification to the current code that might work for you.
If you have a lot of data and it is too slow, we will still need to look at a total redesign.

Sub rowcopy_mod()
    Const FirstRow = 5
    Dim rij As Long
    Dim n As Long
    Dim src As Worksheet
    Dim trg As Worksheet

    Set src = Sheets("Ridon 22")

    Application.ScreenUpdating = False
    
    For n = FirstRow To src.Cells(Rows.Count, "A").End(xlUp).Row
        Set trg = Nothing
        If src.Cells(n, "AE").Value <> "" Then
            On Error Resume Next
            Set trg = Worksheets(src.Cells(n, "AE").Value & " 22")
            If Err = 0 Then
                rij = trg.Cells(Rows.Count, "A").End(xlUp).Row + 1
                With src
                    .Range(.Cells(n, "A"), .Cells(n, "AZ")).Copy
                End With
                trg.Cells(rij, "A").PasteSpecial
            Else
                Err.Clear
                Set trg = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
                trg.Name = src.Cells(n, "AE").Value & " 22"
                With src
                    .Range(.Cells(1, "A"), .Cells(4, "AZ")).Copy
                End With
                trg.Cells(1, "A").PasteSpecial
                rij = trg.Cells(Rows.Count, "A").End(xlUp).Row + 1
                With src
                    .Range(.Cells(n, "A"), .Cells(n, "AZ")).Copy
                End With
                trg.Cells(rij, "A").PasteSpecial
            End If
        End If
    Next n
    On Error GoTo 0
    
    Application.ScreenUpdating = True
    
End Sub

 

[brankscaffold]

voorbeeld-klad (3).xlsx
	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	AW	AX	AY	AZ
1
2
3
4
5	Dag	week	Datum	Debit Factuur Nr.	Credit Factuur Nr.	Opdrachtbon		Soort	m1 lang	m1 hoog	m²	Debit. Eenheid	Debit Prijs	Debit btw%	Debit Btw.	Debit/uin	Credit. Eenheid	Credit Prijs	Credit btw%	Credit Btw.	Credi/uit	Over	btw			week	dag	bet. Termijn	Datum	Project	Debit Naam	Credit Naam	Datum	week		Betaald datum	Bedrag	Bedrag		week	Nog te betalen	Totaal Betaald		Betaaldatum	Bedrag	Bedrag		week	Nog te betalen	Totaal Betaald		over
6		1			RDS2022-0001			Demontage Steiger	1	630	630	1	2,5	0	0	€ 2,50	630	2,45	0	0	€ 1.543,50	€ 1.541,00	€ 0,00			20	vr	30	20-5-2022	Gorinchem Kolonel Kavel 5	Asindo	Ridon	19-6-2022	12			€ 0,00	€ 0,00	jan	0	€ 2,50	€ 0,00		0-0-0	€ 0,00		0-0-9	#WAARDE!	€ 1.543,50	€ 0,00		€ 0,00
7		2			RDS2022-0002			Demontage Steiger	2	630	1260	1	2,5	0	0	€ 2,50	1260	2,45	0	0	€ 3.087,00	€ 3.084,50	€ 0,00			20	vr	30	20-5-2022	Gorinchem Kolonel Kavel 5		Ridon	19-6-2022	12			€ 0,00	€ 0,00	jan	0	€ 2,50	€ 0,00		0-0-0	€ 0,00		0-0-9	#WAARDE!	€ 3.087,00	€ 0,00		€ 0,00
8
9
Asindo 22

Cell Formulas
Range	Formula
O6:O7,T6:T7	O6	=SUM(M6/100*N6)
P6:P7,U6:U7	P6	=L6*M6+O6*L6
Q6:Q7	Q6	=SUM(K6)
V6:V7	V6	=SUM(U6,-P6,-W6)
W6:W7	W6	=SUM(-O6,T6)
Z6:Z7	Z6	=WEEKNUM(AC6,21)
AA6:AA7	AA6	=TEXT(AC6,"DDD")
AM6:AM7	AM6	=TEXT(AJ6,"mmm")
AN6:AN7,AV6:AV7	AN6	=WEEKNUM(AJ6,1)
AO6:AO7	AO6	=SUM(P6,-AP6)
AP6:AP7,AX6:AX7	AP6	=SUM(AK6:AL6)
AW6:AW7	AW6	=SUM(U6,-AX6)
K6:K7	K6	=SUM(I6*J6)
AG6:AG7	AG6	=SUM(AC6,AB6)
AZ6:AZ7	AZ6	=SUM(-AP6,AX6)

 

[brankscaffold]

Rather than waiting for your response and most likely totally redesigning the code, here is a modification to the current code that might work for you.
If you have a lot of data and it is too slow, we will still need to look at a total redesign.

Sub rowcopy_mod()
    Const FirstRow = 5
    Dim rij As Long
    Dim n As Long
    Dim src As Worksheet
    Dim trg As Worksheet

    Set src = Sheets("Ridon 22")

    Application.ScreenUpdating = False
   
    For n = FirstRow To src.Cells(Rows.Count, "A").End(xlUp).Row
        Set trg = Nothing
        If src.Cells(n, "AE").Value <> "" Then
            On Error Resume Next
            Set trg = Worksheets(src.Cells(n, "AE").Value & " 22")
            If Err = 0 Then
                rij = trg.Cells(Rows.Count, "A").End(xlUp).Row + 1
                With src
                    .Range(.Cells(n, "A"), .Cells(n, "AZ")).Copy
                End With
                trg.Cells(rij, "A").PasteSpecial
            Else
                Err.Clear
                Set trg = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
                trg.Name = src.Cells(n, "AE").Value & " 22"
                With src
                    .Range(.Cells(1, "A"), .Cells(4, "AZ")).Copy
                End With
                trg.Cells(1, "A").PasteSpecial
                rij = trg.Cells(Rows.Count, "A").End(xlUp).Row + 1
                With src
                    .Range(.Cells(n, "A"), .Cells(n, "AZ")).Copy
                End With
                trg.Cells(rij, "A").PasteSpecial
            End If
        End If
    Next n
    On Error GoTo 0
   
    Application.ScreenUpdating = True
   
End Sub

thanks and sorry for the delay. i'm going to try it now. So much has happened in my life at once that I didn't have time for anything for a while

 

[brankscaffold]

it looks much better already, create new worksheet with correct name
only 1 line was copied to asindo

Worksheet Ridon

voorbeeld-klad (3).xlsx
	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	AW	AX	AY	AZ
1				Invullen								#VERW!
2				Niet invullen
3					Gewerkt Crediteur			AE								Debiteur/uit tegoed					Crediteur/in tegoed/ klant					Factuur gegevens							Vervaldatum			debiteuren betaald / uit								crediteuren betaald /in								Totaal Credit Betaald
4	Dag	week	Datum	Debit Factuur Nr.	Credit Factuur Nr.	Opdrachtbon		Soort	m1 lang	m1 hoog	m²	Debit. Eenheid	Debit Prijs	Debit btw%	Debit Btw.	Debit/uin	Credit. Eenheid	Credit Prijs	Credit btw%	Credit Btw.	Credi/uit	Over	btw			week	dag	bet. Termijn	Datum	Project	Debit Naam	Credit Naam	Datum	week		Betaald datum	Bedrag	Bedrag		week	Nog te betalen	Totaal Betaald		Betaaldatum	Bedrag	Bedrag		week	Nog te betalen	Totaal Betaald		over
5		1			RDS2022-0001			Demontage Steiger	1	630	630	1	2,5	0	0	€ 2,50	630	2,45	0	0	€ 1.543,50	€ 1.541,00	€ -			20	vr	30	20-5-2022	Gorinchem Kolonel Kavel 5	Asindo	Ridon	19-6-2022	12			€ 0,00	€ 0,00	jan	0	€ 2,50	€ 0,00		0-0-0	€ 0,00		0-0-9	####	€ 1.543,50	€ 0,00		€ 0,00
6		2			RDS2022-0002			Demontage Steiger	2	630	1260	1	2,5	0	0	€ 2,50	1260	2,45	0	0	€ 3.087,00	€ 3.084,50	€ -			20	vr	30	20-5-2022	Gorinchem Kolonel Kavel 5	ed	Ridon	19-6-2022	12			€ 0,00	€ 0,00	jan	0	€ 2,50	€ 0,00		0-0-0	€ 0,00		0-0-9	####	€ 3.087,00	€ 0,00		€ 0,00
7		3			RDS2022-0003			Demontage Steiger	1	630	630	1	2,5	0	0	€ 2,50	630	2,45	0	0	€ 1.543,50	€ 1.541,00	€ -			20	vr	30	20-5-2022	Gorinchem Kolonel Kavel 5	piet	Ridon	19-6-2022	12			€ 0,00	€ 0,00	jan	0	€ 2,50	€ 0,00		0-0-0	€ 0,00		0-0-9	####	€ 1.543,50	€ 0,00		€ 0,00
8		4			RDS2022-0004			Demontage Steiger	5	630	3150	1	2,5	0	0	€ 2,50	3150	2,45	0	0	€ 7.717,50	€ 7.715,00	€ -			20	vr	30	20-5-2022	Gorinchem Kolonel Kavel 5	Hans	Ridon	19-6-2022	12			€ 0,00	€ 0,00	jan	0	€ 2,50	€ 0,00		0-0-0	€ 0,00		0-0-9	####	€ 7.717,50	€ 0,00		€ 0,00
9		5			RDS2022-0005			Demontage Steiger	3	635	1905	1	2,5	0	0	€ 2,50	1905	2,45	0	0	€ 4.667,25	€ 4.664,75	€ -			20	vr	30	20-5-2022	Gorinchem Kolonel Kavel 5	Asindo	Ridon	19-6-2022	12			€ 0,00	€ 0,00	jan	0	€ 2,50	€ 0,00		0-0-0	€ 0,00		0-0-9	####	€ 4.667,25	€ 0,00		€ 0,00
10		5			RDS2022-0006			Demontage Steiger	4	640	2560	1	2,5	0	0	€ 2,50	2560	2,45	0	0	€ 6.272,00	€ 6.269,50	€ -			20	vr	30	20-5-2022	Gorinchem Kolonel Kavel 5	Asindo	Ridon	19-6-2022	12			€ 0,00	€ 0,00	jan	0	€ 2,50	€ 0,00		0-0-0	€ 0,00		0-0-9	####	€ 6.272,00	€ 0,00		€ 0,00
Ridon 22

Cell Formulas
Range	Formula
L1	L1	=SUM(#REF!)
O5:O10,T5:T10	O5	=SUM(M5/100*N5)
P5:P10,U5:U10	P5	=L5*M5+O5*L5
Q5:Q10	Q5	=SUM(K5)
V5:V10	V5	=SUM(U5,-P5,-W5)
W5:W10	W5	=SUM(-O5,T5)
Z5:Z10	Z5	=WEEKNUM(AC5,21)
AA5:AA10	AA5	=TEXT(AC5,"DDD")
AM5:AM10	AM5	=TEXT(AJ5,"mmm")
AN5:AN10	AN5	=WEEKNUM(AJ5,1)
AO5:AO10	AO5	=SUM(P5,-AP5)
AP5:AP10,AX5:AX10	AP5	=SUM(AK5:AL5)
AW5:AW10	AW5	=SUM(U5,-AX5)
K5:K10	K5	=SUM(I5*J5)
AG5:AG10	AG5	=SUM(AC5,AB5)
AZ5:AZ10	AZ5	=SUM(-AP5,AX5)

Worksheet Asindo

voorbeeld-klad (3).xlsx
	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	AW	AX
3					Gewerkt Crediteur			AE								Debiteur/uit tegoed					Crediteur/in tegoed/ klant					Factuur gegevens							Vervaldatum			debiteuren betaald / uit								crediteuren betaald /in
4	Dag	week	Datum	Debit Factuur Nr.	Credit Factuur Nr.	Opdrachtbon		Soort	m1 lang	m1 hoog	m²	Debit. Eenheid	Debit Prijs	Debit btw%	Debit Btw.	Debit/uin	Credit. Eenheid	Credit Prijs	Credit btw%	Credit Btw.	Credi/uit	Over	btw			week	dag	bet. Termijn	Datum	Project	Debit Naam	Credit Naam	Datum	week		Betaald datum	Bedrag	Bedrag		week	Nog te betalen	Totaal Betaald		Betaaldatum	Bedrag	Bedrag		week	Nog te betalen	Totaal Betaald
5		1			RDS2022-0001			Demontage Steiger	1	630	630	1	2,5	0	0	€ 2,50	630	2,45	0	0	########	########	€ -			20	vr	30	########	Gorinchem Kolonel Kavel 5	Asindo	Ridon	########	12			€ 0,00	€ 0,00	jan	0	€ 2,50	€ 0,00		0-0-0	€ 0,00		0-0-9	########	########	€ 0,00
Asindo 22

Cell Formulas
Range	Formula
K5	K5	=SUM(I5*J5)
O5,T5	O5	=SUM(M5/100*N5)
P5,U5	P5	=L5*M5+O5*L5
Q5	Q5	=SUM(K5)
V5	V5	=SUM(U5,-P5,-W5)
W5	W5	=SUM(-O5,T5)
Z5	Z5	=WEEKNUM(AC5,21)
AA5	AA5	=TEXT(AC5,"DDD")
AG5	AG5	=SUM(AC5,AB5)
AM5	AM5	=TEXT(AJ5,"mmm")
AN5	AN5	=WEEKNUM(AJ5,1)
AO5	AO5	=SUM(P5,-AP5)
AP5,AX5	AP5	=SUM(AK5:AL5)
AW5	AW5	=SUM(U5,-AX5)

 

[Alex Blakenburg]

only 1 line was copied to asindo

OK It's pretty late here, I will have a look tomorrow.

 

[Alex Blakenburg]

only 1 line was copied to asindo

Ok can you change the line below from "A" to "AE" (below is after the change)

For n = FirstRow To src.Cells(Rows.Count, "AE").End(xlUp).Row

 

[brankscaffold]

I have adjusted this.

now it must be checked if there are no duplicates.
on the basis of four rows that may not be equal in the same row with less, these must be added to the worksheet. not the same with four.
(B,E, H, AD) these are the values for checking

For n = FirstRow To src.Cells(Rows.Count, "AE").End(xlUp).Row
        Set trg = Nothing
        If src.Cells(n, "AE").Value <> "" Then
            On Error Resume Next
            Set trg = Worksheets(src.Cells(n, "AE").Value & " 22")
            If Err = 0 Then
                rij = trg.Cells(Rows.Count, "E").End(xlUp).Row + 1

 

[Alex Blakenburg]

If you are saying that if the current row has the same value in columns B, E, H & AD, then don't copy that row, then confirm that is the case and I will modify the code.
If you want full duplicate checking (ie not just this row with the previous row) you will need to open a new thread.

 

[brankscaffold]

If you are saying that if the current row has the same value in columns B, E, H & AD, then don't copy that row, then confirm that is the case and I will modify the code.
If you want full duplicate checking (ie not just this row with the previous row) you will need to open a new thread.

yes please it is the case

 

[Alex Blakenburg]

See if this does what you need.

Sub rowcopy_mod_v02()
   
    Const FirstRow = 5
    Dim rij As Long
    Dim n As Long
    Dim src As Worksheet
    Dim trg As Worksheet
    Dim OKToCopy As String

    Set src = Sheets("Ridon 22")

    Application.ScreenUpdating = False
   
    For n = FirstRow To src.Cells(Rows.Count, "AE").End(xlUp).Row
        OKToCopy = "N"
        Set trg = Nothing
        If src.Cells(n, "AE").Value <> "" Then
            If n = FirstRow Then
                OKToCopy = "Y"
            ElseIf src.Cells(n, "B").Value <> src.Cells(n - 1, "B").Value Then
                OKToCopy = "Y"
            ElseIf src.Cells(n, "E").Value <> src.Cells(n - 1, "E").Value Then
                OKToCopy = "Y"
            ElseIf src.Cells(n, "H").Value <> src.Cells(n - 1, "H").Value Then
                OKToCopy = "Y"
            ElseIf src.Cells(n, "AD").Value <> src.Cells(n - 1, "AD").Value Then
                OKToCopy = "Y"
            Else
                OKToCopy = "N"
            End If
           
            If OKToCopy = "Y" Then
                    On Error Resume Next
                    Set trg = Worksheets(src.Cells(n, "AE").Value & " 22")
                    If Err <> 0 Then
                        Err.Clear
                        Set trg = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
                        trg.Name = src.Cells(n, "AE").Value & " 22"
                        With src
                            .Range(.Cells(1, "A"), .Cells(4, "AZ")).Copy
                        End With
                        trg.Cells(1, "A").PasteSpecial
                    End If
                    rij = trg.Cells(Rows.Count, "AE").End(xlUp).Row + 1
                    With src
                        .Range(.Cells(n, "A"), .Cells(n, "AZ")).Copy
                    End With
                    trg.Cells(rij, "A").PasteSpecial
            End If
        End If
    Next n
    On Error GoTo 0
   
    Application.ScreenUpdating = True
   
End Sub