如何复制/粘贴部分行

Question

除了复制/粘贴部分之外，以下宏可以完成其设计的所有功能。我不知道该做什么更正。

宏搜索每个工作表的特定列（F 或 G），寻找任何大于零的值。如果找到，它应该复制 Cols 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

结束子

Download Example 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