如何复制/粘贴部分行

Question

除了复制/粘贴部分外，以下宏可以执行其设计的所有操作。我不知道该做什么改正。

宏搜索每个工作表的特定列(F或G(，寻找任何大于ZERO的值。如果找到，它应该复制列B:F或B:G(取决于搜索的列(，并将这些值粘贴到相应的工作表中。

感谢您的帮助！

Option Explicit
Sub SampleCopy()
Dim ws As Worksheet
Dim c As Range

'On Error Resume Next
Application.ScreenUpdating = False
For Each ws In Worksheets

Select Case ws.Name

Case "In Stock", "To Order", "Sheet1"
'If it's one of these sheets, do nothing

Case Else

For Each c In Range("F15:F" & Cells(Rows.Count, 6).End(xlUp).Row)
If c.Value >= 1 Then
Range("B:G").Copy Sheets("In Stock").Cells(Rows.Count, 2).End(xlUp)(1)  'Edit sheet name
End If
Next c

For Each c In Range("G15:G50" & Cells(Rows.Count, 7).End(xlUp).Row)
If c.Value >= 1 Then
Range("B:G").Copy Sheets("To Order").Cells(Rows.Count, 2).End(xlUp)(1)  'Edit sheet name
End If
Next c

End Select
Next ws
Application.ScreenUpdating = True

结束子

下载WB 示例

Answer 1

试试这个代码。注意表格ws.Range、ws.Cells的明确指示，以及在表格In Stock、To Order上填写单元格B14的必要性，以便在表格中的最后一行为空时正确确定：

Option Explicit
Sub SampleCopy()
Dim ws As Worksheet
Dim c As Range, rngToCopy As Range

'On Error Resume Next
'Application.ScreenUpdating = False
For Each ws In Worksheets

Select Case ws.Name

Case "In Stock", "To Order", "Sheet1"
'If it's one of these sheets, do nothing

Case Else

For Each c In ws.Range("F15:F" & ws.Cells(Rows.Count, 6).End(xlUp).Row)
If c.Value > 0 Then
Set rngToCopy = Intersect(ws.Columns("B:G"), c.EntireRow)
If Not rngToCopy Is Nothing Then
rngToCopy.Copy Sheets("In Stock").Cells(Rows.Count, 2).End(xlUp)(2).Resize(, rngToCopy.Columns.Count) 'Edit sheet name
End If
End If
Next c

For Each c In ws.Range("G15:G" & ws.Cells(Rows.Count, 7).End(xlUp).Row)
If c.Value > 0 Then
Set rngToCopy = Intersect(ws.Columns("B:G"), c.EntireRow)
If Not rngToCopy Is Nothing Then
rngToCopy.Copy Sheets("To Order").Cells(Rows.Count, 2).End(xlUp)(2).Resize(, rngToCopy.Columns.Count)  'Edit sheet name
End If
End If
Next c

End Select
Next ws
Application.ScreenUpdating = True
End Sub