将所有值从一张纸复制并粘贴到另一张纸

Question

我有一个宏，可以创建一个充满数据的工作表。我最近添加了新的工作表，以便每个值都可以包含唯一的值。例如，如果一行包含“ Pole Change Out”，则将整行复制并粘贴到“ Pole Change Out”工作表中。有4种不同的床单。我的问题是，由于某些值是由vba中的公式确定的，因此某些值不会移到新工作表中。

Sub copy_paste_based_on_cell_interior_rgb()
Dim LastRow As Long

Dim i As Long, j As Long

'Find the last used row in a Column: column A in this example
 With Worksheets("Make-Ready")
  LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
 End With

'first row number where you need to paste values in Sheet1'
With Worksheets("Pole Change Out")
  j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With

For i = 1 To LastRow
   With Worksheets("Make-Ready")
       If .Cells(i, 27).Value = "Pole Change-Out" Then
           .Rows(i).Copy Destination:=Worksheets("Pole Change Out").Range("A" & j)
           j = j + 1
       ElseIf .Cells(i, 27).Value = "New Midspan Pole" Then
           .Rows(i).Copy Destination:=Worksheets("Midspan Poles").Range("A" & j)
           j = j + 1
       ElseIf .Cells(i, 104).Value = "Yes" Then
           .Rows(i).Copy Destination:=Worksheets("Anchor Replacement").Range("A" & j)
           j = j + 1
       End If
   End With
   Next i

   End Sub

Answer 1

正如@scottCraner和其他人指出的那样。您正在尝试使用其他两张纸上的一张纸的第一个空单元格变量。代码更新将自动更新每张纸的第一个空白单元格。

Sub copy_paste_based_on_cell_interior_rgb()
Dim LastRow As Long

Dim i As Long ', j As Long

'Find the last used row in a Column: column A in this example
 With Worksheets("Make-Ready")
  LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
 End With

'first row number where you need to paste values in Sheet1'
'With Worksheets("Pole Change Out")
'  j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
'End With

For i = 1 To LastRow
   With Worksheets("Make-Ready")
       If .Cells(i, 27).Value = "Pole Change-Out" Then
           .Rows(i).Copy Destination:=Worksheets("Pole Change Out").Cells(Rows.Count, 1).End(xlUp).Offset(1)

           'j = j + 1
       ElseIf .Cells(i, 27).Value = "New Midspan Pole" Then
           .Rows(i).Copy Destination:=Worksheets("Midspan Poles").Cells(Rows.Count, 1).End(xlUp).Offset(1)

           'j = j + 1
       ElseIf .Cells(i, 104).Value = "Yes" Then
           .Rows(i).Copy Destination:=Worksheets("Anchor Replacement").Cells(Rows.Count, 1).End(xlUp).Offset(1)

           'j = j + 1
       End If
   End With
   Next i

   End Sub