Question

此工作簿是为用户表单设置的，用于输入采购订单信息，以便将其添加到动态采购订单日志中。登录后，用户将关闭用户表单并选择组合框值 Yes 或 No 以指示是否应从每月预算中扣除该采购订单。

如果用户选择否，则应将整行复制到工作簿的下一页，也就是下个月。仅当组合框值 = No.
时，这才应通过 Worksheet Selection_Change 事件发生如果用户选择是，其他公式会将值添加到总扣除额中，因此循环应忽略它。

此工作簿中的页面完全相同，因此第二个月的范围将与第一个月的 C14:H14 相同，根据选择的 NO 值的数量再次动态更新。

我无法仅找到无值并将行 C14:H14 复制到下一个工作表中的下一个可用行。

Sub Transfer()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lRow1 As Long
Dim lRow2 As Long
Dim i As Long
Dim Crit As Range

Set ws1 = ActiveSheet
Set ws2 = ActiveSheet.Next

lRow1 = ws1.Range("J" & Rows.Count).End(xlUp).Row

For i = 14 To lRow1
    If ws1.Cells(i, 10).Value = "No" Then

        ws1.Range("C" & i & ":H" & lRow1).Copy
        ws2.Activate

        lRow2 = ws2.Range("J" & Rows.Count).End(xlUp).Offset(1, 0).Row

        ws2.Range("C14:H" & lRow2).PasteSpecial Paste:=xlPasteValues
    End If
Next i

End Sub

此代码复制最后两个数据点并忽略条件。如果它们在整个数据集中混合，它将复制 Yes 和 No。

Answer 1

你只需要复制每一行 - 你复制的是整块行

Sub Transfer()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lRow1 As Long
    Dim lRow2 As Long
    Dim i As Long
    Dim Crit As Range
    
    Set ws1 = ActiveSheet
    Set ws2 = NextVisibleWorksheet(ws1) 'find next sheet
    If ws2 Is Nothing Then  'check we got a sheet
        msgbox "No sheet found after " & ws1.Name
        Exit sub
    End If
    
    lRow1 = ws1.Range("J" & Rows.Count).End(xlUp).Row
    lRow2 = ws2.Range("J" & Rows.Count).End(xlUp).Offset(1, 0).Row

    For i = 14 To lRow1
        If ws1.Cells(i, 10).Value = "No" Then
            With ws1.Range("C" & i & ":H" & i)
                ws2.Cells(lRow2, "C").Resize(1, .Columns.Count).Value = .Value
                lRow2 = lRow2 + 1
            End With
        End If
    Next i

End Sub

'given a worksheet, find the next visible sheet (if any)
Function NextVisibleWorksheet(ws As Worksheet)
    Dim rv As Worksheet
    Set rv = ws.Next 'does not raise an error if no more sheets...
    If Not rv Is Nothing Then
        Do While rv.Visible <> xlSheetVisible
            Set rv = rv.Next
            If rv Is Nothing Then Exit Do 'edit - added this check
        Loop
    End If
    Set NextVisibleWorksheet = rv
End Function

根据列中的条件将行从一张纸复制到另一张

1 个答案: