如何 Copy/Paste 部分行

Question

除了 copy/paste 部分，下面的宏完成了它设计的所有功能。我不知道该做什么correction/s。

宏搜索每个 sheet 特定列（F 或 G），寻找任何大于零的值。如果找到，它应该复制 Cols B:F 或 B:G（取决于搜索的列）并将这些值粘贴到适当的 worksheet.

感谢您的协助！

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

试试这个代码。注意sheetws.Range,ws.Cells的显式指示和sheetIn Stock上需要填写的单元格B14, 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, 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

如何 Copy/Paste 部分行

How To Copy/Paste Partial Row

vba

copy

row

paste

partial