Question

我们为所有机器创建了一张订单，主页是“订单”。我们会在当天结束时将此表发送给采购部门。当我们运行宏来通过电子邮件发送文件时，我们希望宏也将每一行复制到特定的机器工作表。例如。标记为'Slicer'的行转到'Slicer'表，'blender'转换为'blender'等。

这是我到目前为止所得到的：

Sub PrintToNetwork()

    ActiveWorkbook.Save
    Range("A2:N25").Font.Size = 11
    Dim OutApp As Object
    Dim OutMail As Object
    Dim answer As Integer
    answer = MsgBox("Are you sure you want to Print & Send the sheet?", vbYesNo + vbQuestion, "Empty Sheet")
    If answer = vbYes Then
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)

        On Error Resume Next
        With OutMail
            .To = ""
            .CC = ""
            .BCC = ""
            .Subject = "Retail Order Sheet"
            .Body = "Hi Andy, Please order."
            .Attachments.Add ActiveWorkbook.FullName
            .Send
        End With
        On Error GoTo 0

        Set OutMail = Nothing
        Set OutApp = Nothing
        Range("A1:N25").Select
        ActiveSheet.PageSetup.PrintArea = "$A$1:$N$25"
        oldprinter = Application.ActivePrinter

        For i = 0 To 15
           curNePrint = Format(i, "00")
           On Error Resume Next
              Application.ActivePrinter = "\\10.17.0.9\CCFN_Retail_MFP_BW on Ne" & curNePrint & ":"
        Next i

        ActiveWindow.Selection.PrintOut Copies:=1
        Application.ActivePrinter = oldprinter
        On Error GoTo 0
     Else

    End If
End Sub

Answer 1

假设目标工作表上的行位置是通过检查与包含工作表名称的列相同的列来确定的，则类似下面的内容可能会起作用。 DispatchRows子扫描prngWorksheetNames，查找按名称存在的工作表。

您必须通过传递包含工作表名称的范围来调用DispatchRows。例如，如果源工作表名称位于工作表摘要，范围C2：C50，则您将调用DispatchRows ThisWorkbook.Worksheets("Summary").Range("C2:C50")。

Option Explicit

'Copies entire rows to worksheets whose names are found within prngWorksheetNames.
'ASSUMPTION: on the destination worksheet, a copied row is appended at the lowest empty spot in the same column as prngWorksheetNames.
Public Sub DispatchRows(ByVal prngWorksheetNames As Excel.Range)
    Dim lRow As Long
    Dim rngWorksheetName As Excel.Range
    Dim sDestWorksheetTabName As String
    Dim oDestWs As Excel.Worksheet
    Dim bScreenUpdating As Boolean
    Dim bEnableEvents As Boolean

    On Error GoTo errHandler

    bScreenUpdating = Application.ScreenUpdating
    bEnableEvents = Application.EnableEvents

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    For lRow = 1 To prngWorksheetNames.Rows.Count
        Set rngWorksheetName = prngWorksheetNames.Cells(lRow, 1)
        sDestWorksheetTabName = CStr(rngWorksheetName.Value)

        If TryGetWorksheetByTabName(ThisWorkbook, sDestWorksheetTabName, oDestWs) Then
            'Make sure there are no active autofilters on the destination worksheet, as they would typically interfere with the copy operation.
            If oDestWs.FilterMode Then
                oDestWs.ShowAllData
            End If

            'Copy and paste.
            rngWorksheetName.EntireRow.Copy
            oDestWs.Cells(oDestWs.Rows.Count, prngWorksheetNames.Column).End(xlUp).Offset(1).EntireRow.PasteSpecial xlPasteAll
        End If
    Next

Cleanup:
    On Error Resume Next
    Set rngWorksheetName = Nothing
    Set oDestWs = Nothing
    Application.CutCopyMode = False
    Application.EnableEvents = bEnableEvents
    Application.ScreenUpdating = bScreenUpdating
    Exit Sub

errHandler:
    MsgBox Err.Description, vbExclamation + vbOKOnly, "Error"
    Resume Cleanup
End Sub

'Returns True, and a reference to the target worksheet, if worksheet psName is found by name on pwbkHost.
Public Function TryGetWorksheetByTabName(ByVal pwbkHost As Excel.Workbook, ByVal psName As String, ByRef pshtResult As Excel.Worksheet) As Boolean
    Set pshtResult = Nothing

    On Error Resume Next
    Set pshtResult = pwbkHost.Worksheets(psName)

    TryGetWorksheetByTabName = Not pshtResult Is Nothing
End Function

Answer 2

这是一个非常简单的脚本来实现你想要的。适当地插入代码，或从宏中调用它。我测试了很多次以确保它有效。

Sub CopyLines()
 Dim mySheet
 Dim LastRow As Long
 Dim LastShtRow As Long
 Dim j

 LastRow = Sheets("Order Sheet").Cells(Rows.Count, 1).End(xlUp).Row

 For j = 2 To LastRow Step 1

    mySheet = Range("B" & j).Value
    LastShtRow = Sheets(mySheet).Cells(Rows.Count, 1).End(xlUp).Row

    Range("A" & j & ":" & "N" & j).Copy

    Sheets(mySheet).Range("A" & LastShtRow + 1).PasteSpecial xlPasteValues

 Next j

 Application.CutCopyMode = False

End Sub

根据内容复制行并将其粘贴到根据行内容选择的不同工作表中

2 个答案: