要将值从工作表1复制到工作表2并使用vba将其粘贴到所需的位置

Question

My objective is to copy values from cells in sheet 1 "B5" onwards and paste it to sheet 2 "C11" onwards below is the code not working properly

Sub SCMPROCUREMENT()

' SUPPLY CHAIN MANAGEMENT PROCUREMENT


Worksheets("Sheet1").Select


Range("B5:B100000").Select

finalrow = Cells(Rows.Count, 2).End(xlUp).Row

For x = 5 To finalrow

If Worksheets("sheet1").Cells(x, 2).Font.Bold = False Then

Worksheets("sheet1").Select

Cells(x, 2).Select

Selection.Copy

ThisWorkbook.Worksheets("Sheet2").Range("C11").Select


ActiveSheet.Paste


End If
Next x

End Sub

Answer 1

a) your ThisWorkbook.Worksheets("Sheet2").Range("C11") doesn't work like that

b) you need a counter for the second list, otherwise you keep overwriting C11

Sub SCMPROCUREMENT()

    ' SUPPLY CHAIN MANAGEMENT PROCUREMENT

    Dim count As Integer

    For x = 5 To Worksheets("Sheet1").Cells(Rows.count, 2).End(xlUp).Row

        If Worksheets("Sheet1").Cells(x, 2).Font.Bold = False Then

            Worksheets("Sheet1").Cells(x, 2).Copy

            Worksheets("Sheet2").Cells(11 + count, 3).Select
            ActiveSheet.Paste

            count = count + 1

        End If
    Next x

End Sub

Answer 2

Sub SCMPROCUREMENT()

    ' SUPPLY CHAIN MANAGEMENT PROCUREMENT

    Application.ScreenUpdating = False

    Dim count As Integer

    With Worksheets("Sheet1")

        For x = 5 To .Cells(Rows.count, 2).End(xlUp).Row

            If .Cells(x, 2).Font.Bold = False Then

                .Cells(x, 2).Copy Worksheets("Sheet2").Cells(11 + count, 3)
                count = count + 1
            End If
        Next x

    End With

    Application.ScreenUpdating = True

End Sub