如何复制/粘贴部分行

问题描述

以下宏完成了它设计的所有任务，除了复制/粘贴部分。我不知道要做什么更正。

宏搜索每个工作表、特定列（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

解决方法

试试这个代码。注意工作表ws.Range、ws.Cells的明确指示以及需要在工作表B14、In Stock上填写单元格To Order才能正确判断表中的最后一行，以防它们为空：

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,rngToCopy.Columns.Count)  'Edit sheet name
                       End If
                   End If
               Next c
          
        End Select
    Next ws

    Application.ScreenUpdating = True
End Sub