使用复制创建价目表，使用 VBA 粘贴

Question

I have a template Pricelist, were there are about 2600 rows, from this based on one column you pick what products you want. I want to copy these rows into a new sheet. Use the following code, but does some things it shouldn't. Any suggestions?

Private Sub CmdAdd_Click()
    Dim rng As Range
    Dim cel As Range

    Set rng = Range("B8:B39")
    For Each cel In rng
        If cel.Value = "X" Then
            cel.EntireRow.Select
            Application.CutCopyMode = False
            Selection.Copy Destination:=Sheets("NewPricelist").Range("A" & Rows.Count).End(xlDown).Offset(1, 0)
    
        End If
    Next cel
End Sub

Answer 1

I believe the issue you are facing is due to xlDown.
You go from rows.count (end of worksheet) and down...

If we make that xlUp then the code copies the rows to the other sheet as expected. (if that is the expected)

Private Sub CmdAdd_Click()

    Dim rng As Range
    Dim cel As Range
       
       
        
    
    Set rng = Range("B8:B39")
    For Each cel In rng
        If cel.Value = "X" Then
            'cel.EntireRow.Select
            'Application.CutCopyMode = False
            cel.EntireRow.Copy Destination:=Sheets("NewPricelist").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)    
        End If
    Next cel
End Sub

I also commented out the select to make the code faster

Answer 2

I have tested your code, but by the looks of it you are pasting the row all the way down in the bottom of the worksheet. On row 1048576, and then overwriting the values.

I take it you want to paste them in an order on the top of your worksheet?

Private Sub CmdAdd_Click()
Dim rng As Range
Dim cel As Range
Dim icount As Integer
Set rng = Range("B8:B39")

icount = 0

For Each cel In rng
    If cel.Value = "X" Then
    icount = icount + 1
        cel.EntireRow.Select
        Application.CutCopyMode = False
        Selection.Copy
        Selection.Copy Destination:=Sheets("NewPricelist").Range("A" & 0 + icount)
    End If
Next cel


End Sub