Копирование содержимого с листа на основе значения на другой с помощью vba, но значение перезаписывается

Есть ниже VBA код, в котором я пытаюсь скопировать США, разработчик и дата с листа «P1» в «sheet2» на основе проекта(т. е. столбец A)

Ниже приведен код, который я использую, но я вижу, что значение в ячейке перезаписывается как часть цикла, не могли бы вы помочь

Sub transfer()
Dim i As Long, j As Long, n As Long, lastrow1 As Long, longrow2 As Long, lastrow3 As Long

Dim myname As String
lastrow1 = Sheets("P1").Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To lastrow1
myname = Sheets("P1").Cells(i, "A").Value

Sheets("sheet2").Activate
lastrow2 = Sheets("sheet2").Range("A" & Rows.Count).End(xlUp).Row

For j = 2 To lastrow2
        If Sheets("sheet2").Cells(j, "A").Value = myname Then
        Sheets("P1").Activate
        Sheets("P1").Range(Cells(i, "B"), Cells(i, "D")).Copy
         Sheets("sheet2").Activate
         Sheets("sheet2").Range(Cells(j, "B"), Cells(j, "D")).Select
         ActiveSheet.Paste                

        End If    
       Next j

Application.CutCopyMode = False
Next i

Sheets("P1").Activate
Sheets("P1").Range("A1").Select            
End Sub

Опубликованное Изображение

Метки

1 ответ

  1. Это не очень хорошая практика в использованииSelection, Copyи Pasteварианты в VBA. Попробуйте использовать Valuesвместо этого. Попробуйте что-то вроде этого:

    Sub transfer()
    Dim i As Long, j As Long, n As Long, lastrow1 As Long, longrow2 As Long, lastrow3 As Long
    
    Dim myname As String
    lastrow1 = Sheets("P1").Range("A" & Rows.Count).End(xlUp).Row
    
    For i = 2 To lastrow1
    myname = Sheets("P1").Cells(i, "A").Value
    
    Sheets("sheet2").Activate
    lastrow2 = Sheets("sheet2").Range("A" & Rows.Count).End(xlUp).Row
    
    For j = 2 To lastrow2
            If Sheets("sheet2").Cells(j, "A").Value = myname Then
            Sheets("sheet2").Range(Cells(i, "B").Value = Sheets("P1").Range(Cells(i, "B").Value
            Sheets("sheet2").Range(Cells(i, "D").Value = Sheets("P1").Range(Cells(i, "D").Value
    
                           End If
    
           Next j
    
    Application.CutCopyMode = False
    Next i
    
    End Sub
    

    Это не совсем то, что я бы сделал, но это должно работать интегрировано с вашим кодом. Если вы хотите, чтобы я опубликовал, как я буду кодировать этот конкретный вопрос, не стесняйтесь спрашивать. (На самом деле я просто сделал что-то подобное для работы несколько дней назад)