how could stop copy to the bottom repeatedly after lastrow contains data

abdo meghari

Active Member
Joined
Aug 3, 2021
Messages
465
Office Version
  1. 2019
Hello
how can I make this code copy data to the bottom after data already existed without repeating copying to the bottom when run the macro more than one time
VBA Code:
Sub COPY_RANGE()
Dim lr As Long, lr2 As Long
With Sheets("PURCHASE")
    lr2 = .Range("B" & .Rows.Count).End(xlUp).Row
    .Range("B2:C" & lr2).Copy
End With
With Sheets("Table 1")
    lr = .Range("B" & .Rows.Count).End(xlUp).Row
    .Range("B" & lr + 1).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
End With

End Sub
SOURCE DATA
REPORT.xlsm
ABCD
1ITEMBRANDSLBU
21BS 1200 R20 18PR G580 THI32
32BS 1200 R20 18PR G580596
43BS 1200R20-18PR R187 JAP19
54BS 1200R24 G580492
65BS 1200R24 G582191
76BS 13 R22.5 R187 JAP82
87BS 175/65R14 EP150 THI4
98BS 185/65R15 B250 JAP4
109BS 185/70R13 EP150 IND4
1110BS 195/55R16 EP300 THI2
1211BS 195R14C 613 JAP44
1312BS 195R14C R623 THI20
1413BS 195R14C R624 HD 106P104P 8 TURK12
1514BS 195R15C 613V JAP8
1615BS 195R15C R623 THI4
1716BS 205/60R16 T005 THI4
1817BS 205/65R15 EP150 IND4
1918BS 205/70R15C R623 THI18
2019BS 205/70R15C R660 TURK418
2120BS 205R16C D840 THI28
2221BS 215/55R17 GR90 IND2
2322BS 215/60R16 ER30 JAP4
2423BS 215/65R16 D688 JAP4
2524BS 215/70R15C R624 HD109S107S 8 TURK16
2625BS 215/70R15C R660 TURK24
2726BS 225/45R18 T005 JAP4
2827BS 225/50R17 EP300 THI4
2928BS 225/55 R16 EP300 IND8
3029BS 225/55R16 T001 JAP2
3130BS 225/60R18 ALENZA1 JAP4
3231BS 225/70R15C R623 JAP28
3332BS 225/70R15C R624 112R110R TURK116
3433BS 225/70R15C R660 112S110S 8 TURK24
3534BS 225/95R16C D619 JAP6
3635BS 235/55R17 ER300 JAP4
3736BS 245/40R17 T001 JAP4
3837BS 245/40R19 T005 JAP2
3938BS 245/70R16 D684 THI2
4039BS 255/70R15C D840 THI276
4140BS 265/70R16 D840 THI1
4241BS 275/65R18 AL01 JAP4
4342BS 285/50R20 D-SPORT JAP20
4443BS 315/80R22.5 R152 JAP12
4544BS 315/80R22.5 R184 JAP22
4645BS 315/80R22.5 R184 THI12
4746BS 315/80R22.5-18PR G580 JAP2
4847BS 385/65 R22.5 R164 JAP2
4948BS 385/65 R22.5 R164 THI6
5049BS 650R16 R230 JAP5
5150BS 700R16 12PR R230 JAP6
5251BS 750R16 R230 TCF JAP224
5352Dayton 1200r24 DA53 THI85
5453Dayton 385/65r22.5 DT40 THI6
5554FIRESTONE 215/60R16 ROADHAWK ITALY4
5655FS 275/65R18 116H IND4
Table 1


REPORT.xlsm
ABC
1SrDescriptionQuantity
21BS 1200R20 G580 TCF450
32BS 1200R20 G580100
43BS 325/95 R24 G582300
54BS 325/95 R24 M84030
65BS 1200R24 G580898
76Dayton 1200R24 DA53 THA100
87BS 1200R24 G58295
98BS 650R16 R230250
109BS 700R16 R230700
1110BS 750R16 R230 TCF199
1211BS 225/60 R18 ALENZA1100
1312BS 195/65 R15 EP150100
1413BS 265/65 R17 D840240
1514BS 205 R14C R62460
1615BS 1200R20 G580 TCF1,533
1716BS 1200R20 G580 THA100
1817BS 1200R20 R187 TCF34
1918BS 750R16 R230 TCF1,069
2019BS 650R16 R230100
2120BS 205R16C D840100
2221BS 225/95 R16C D61964
2322BS 255/70 R15C D840100
2423BS 195/65 R15 T001 91V TL100
2524BS 195/65 R15 EP150100
2625BS 265/65 R17 D840110
2726BS 285/60 R18 D-SPORT JAP15
2827BS 265/60R18 D84040
2928BS 275/65 R18 AL0140
3029BS 225/60 R17 D-SPORT30
3130BS 275/55 R20 ALENZA16
3231BS 1200R20 R187 TCF100
PURCHASE




result should be when run the macro more than one time
REPORT.xlsm
ABCD
1ITEMBRANDSLBU
21BS 1200 R20 18PR G580 THI32
32BS 1200 R20 18PR G580596
43BS 1200R20-18PR R187 JAP19
54BS 1200R24 G580492
65BS 1200R24 G582191
76BS 13 R22.5 R187 JAP82
87BS 175/65R14 EP150 THI4
98BS 185/65R15 B250 JAP4
109BS 185/70R13 EP150 IND4
1110BS 195/55R16 EP300 THI2
1211BS 195R14C 613 JAP44
1312BS 195R14C R623 THI20
1413BS 195R14C R624 HD 106P104P 8 TURK12
1514BS 195R15C 613V JAP8
1615BS 195R15C R623 THI4
1716BS 205/60R16 T005 THI4
1817BS 205/65R15 EP150 IND4
1918BS 205/70R15C R623 THI18
2019BS 205/70R15C R660 TURK418
2120BS 205R16C D840 THI28
2221BS 215/55R17 GR90 IND2
2322BS 215/60R16 ER30 JAP4
2423BS 215/65R16 D688 JAP4
2524BS 215/70R15C R624 HD109S107S 8 TURK16
2625BS 215/70R15C R660 TURK24
2726BS 225/45R18 T005 JAP4
2827BS 225/50R17 EP300 THI4
2928BS 225/55 R16 EP300 IND8
3029BS 225/55R16 T001 JAP2
3130BS 225/60R18 ALENZA1 JAP4
3231BS 225/70R15C R623 JAP28
3332BS 225/70R15C R624 112R110R TURK116
3433BS 225/70R15C R660 112S110S 8 TURK24
3534BS 225/95R16C D619 JAP6
3635BS 235/55R17 ER300 JAP4
3736BS 245/40R17 T001 JAP4
3837BS 245/40R19 T005 JAP2
3938BS 245/70R16 D684 THI2
4039BS 255/70R15C D840 THI276
4140BS 265/70R16 D840 THI1
4241BS 275/65R18 AL01 JAP4
4342BS 285/50R20 D-SPORT JAP20
4443BS 315/80R22.5 R152 JAP12
4544BS 315/80R22.5 R184 JAP22
4645BS 315/80R22.5 R184 THI12
4746BS 315/80R22.5-18PR G580 JAP2
4847BS 385/65 R22.5 R164 JAP2
4948BS 385/65 R22.5 R164 THI6
5049BS 650R16 R230 JAP5
5150BS 700R16 12PR R230 JAP6
5251BS 750R16 R230 TCF JAP224
5352Dayton 1200r24 DA53 THI85
5453Dayton 385/65r22.5 DT40 THI6
5554FIRESTONE 215/60R16 ROADHAWK ITALY4
5655FS 275/65R18 116H IND4
5756BS 1200R20 G580 TCF450
5857BS 1200R20 G580100
5958BS 325/95 R24 G582300
6059BS 325/95 R24 M84030
6160BS 1200R24 G580898
6261Dayton 1200R24 DA53 THA100
6362BS 1200R24 G58295
6463BS 650R16 R230250
6564BS 700R16 R230700
6665BS 750R16 R230 TCF199
6766BS 225/60 R18 ALENZA1100
6867BS 195/65 R15 EP150100
6968BS 265/65 R17 D840240
7069BS 205 R14C R62460
7170BS 1200R20 G580 TCF1533
7271BS 1200R20 G580 THA100
7372BS 1200R20 R187 TCF34
7473BS 750R16 R230 TCF1069
7574BS 650R16 R230100
7675BS 205R16C D840100
7776BS 225/95 R16C D61964
7877BS 255/70 R15C D840100
7978BS 195/65 R15 T001 91V TL100
8079BS 195/65 R15 EP150100
8180BS 265/65 R17 D840110
8281BS 285/60 R18 D-SPORT JAP15
8382BS 265/60R18 D84040
8483BS 275/65 R18 AL0140
8584BS 225/60 R17 D-SPORT30
8685BS 275/55 R20 ALENZA16
8786BS 1200R20 R187 TCF100
88
Table 1

should clear data from row 57 before brings data . should start after last row contains data .
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
To the same row? It should inrease i.
Ok I will go with the old code:
VBA Code:
Sub copyItems()
  Dim lRow1 As Long, lRow2 As Long
  Dim Purchase As Worksheet

  Set Purchase = Worksheets("PURCHASE")
  lRow1 = Worksheets("Table 1").Cells(Rows.Count, 1).End(xlUp).Row
  lRow2 = Purchase.Cells(Rows.Count, 1).End(xlUp).Row
  With Worksheets("Table 1")
    For i = 2 To lRow2
      .Cells(lRow1 + i-1, 1).Value = .Cells(lRow1 + i-2, 1).Value + 1
      .Cells(lRow1 + i-1, 2).Value = Purchase.Cells(i, 2).Value
      .Cells(lRow1 + i-1, 3).Value = Purchase.Cells(i, 3).Value
    Next
  End With
End Sub
 
Upvote 0
I am sure you are doing something wrong. This is exactly the same code letter by letter with the first one.
Only changed this line for auto increment: .Cells(lRow1 + i-1, 1).Value = .Cells(lRow1 + i-2, 1).Value + 1
So the first code is not working anymore? You said it was working?
 
Upvote 0
It worked on the first click. See your self below. Maybe your screenupdating was left False.
In a seperate sub first run the code below only at once. Then try again.
VBA Code:
Sub test()
  Application.ScreenUpdating = True
End Sub

1671450905494.png
 
Upvote 0
what happens if you run the second,third,....?
then should not copy to the bottom again and this is waht happens for me.
 
Upvote 0
Hi abdo meghari,

how about

VBA Code:
Sub MrE_1224954_161610A()
' https://www.mrexcel.com/board/threads/how-could-stop-copy-to-the-bottom-repeatedly-after-lastrow-contains-data.1224954/
  Dim wsTarg As Worksheet
  Dim wsSource As Worksheet
  Dim lngCounter As Long

  Set wsSource = Worksheets("PURCHASE")
  Set wsTarg = Worksheets("Table 1")
  With wsTarg
    For lngCounter = 2 To wsSource.Cells(Rows.Count, 1).End(xlUp).Row
      If WorksheetFunction.CountIf(.UsedRange.Columns(2), wsSource.Cells(lngCounter, 2).Value) = 0 Then
        With .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
          .Value = .Offset(-1, 0).Value + 1
          .Offset(0, 1).Value = wsSource.Cells(lngCounter, 2).Value
          .Offset(0, 2).Value = wsSource.Cells(lngCounter, 3).Value
        End With
      End If
    Next lngCounter
  End With
 
  Set wsTarg = Nothing
  Set wsSource = Nothing
End Sub

Ciao,
Holger
 
Upvote 0
Or limit the range for the check to start in the first row after filled rows in Column A

VBA Code:
Sub MrE_1224954_161610A2()
' https://www.mrexcel.com/board/threads/how-could-stop-copy-to-the-bottom-repeatedly-after-lastrow-contains-data.1224954/
  Dim wsTarg As Worksheet
  Dim wsSource As Worksheet
  Dim lngCounter As Long
  Dim rngSearch As Range

  Set wsSource = Worksheets("PURCHASE")
  Set wsTarg = Worksheets("Table 1")
  With wsTarg
    Set rngSearch = .Range("B" & .Cells(Rows.Count, 1).End(xlUp).Row + 1 & ":B" & .Rows.Count)
    For lngCounter = 2 To wsSource.Cells(Rows.Count, 1).End(xlUp).Row
      If WorksheetFunction.CountIf(rngSearch, wsSource.Cells(lngCounter, 2).Value) = 0 Then
        With .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
          .Value = .Offset(-1, 0).Value + 1
          .Offset(0, 1).Value = wsSource.Cells(lngCounter, 2).Value
          .Offset(0, 2).Value = wsSource.Cells(lngCounter, 3).Value
        End With
      End If
    Next lngCounter
  End With
  
  Set rngSearch = Nothing
  Set wsTarg = Nothing
  Set wsSource = Nothing
End Sub

Ciao,
Holger
 
Upvote 0

Forum statistics

Threads
1,215,425
Messages
6,124,825
Members
449,190
Latest member
rscraig11

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