2

我使用 Excel 为我的公司做一个发票系统。我不得不为使用该程序的其他一些员工提供“虚拟证明”。我使用了几个代码使其成功。我有两张纸： Carolina Fireworks Order Form和Back Order。Carolina Fireworks 订单上有一个宏，可以将任何单元格复制到延期交货订单（这是 Carolina Fireworks 订单的精确副本，除了在放置客户名称的 C7 中，它会自动显示客户名称和 BO）。

我有一个代码可以自动将文件保存到具有 C7（客户名称）和当前日期的特定文件夹中。有没有一种方法可以添加一个代码，如果我点击宏按钮复制 BO 单元格，它将自动使用文件名 C7 和当前日期分别保存延期交货表？那么当我点击 x 按钮时，我的其他代码会自动保存卡罗莱纳烟花订单（表 1）吗？

这有意义吗？我不是代码编写者，所以我必须永远搜索才能使下面的代码正常工作。如果有更好的方法来做到这一点，那么我完全愿意接受！以下是我用于模块 1 的当前代码：

Sub myOpenCode()
'Standard module code, like: Module1.
Dim strCustomer$, strMsg$, myUpDate$, strCustNm$

Application.EnableEvents = True
On Error GoTo myErr

strCustomer = Sheets("Carolina Fireworks Order Form").Range("C7").Value

'Test for current customer!
If strCustomer <> "" Then

strMsg = "The current customer name is:" & vbLf & vbLf & _
strCustomer & vbLf & vbLf & _
"Change this customer name to a different Name?"

'Test for customer name update?
myUpDate = MsgBox(strMsg, vbQuestion + vbYesNo, "Add Customer?")

'Chose "Yes" button!
If myUpDate = 6 Then
'Change current customer's name!
strCustNm = InputBox(strMsg, "Change Customer Name!", "")
End If

'Chose "No" button!
If myUpDate = 7 Then
'Keep current customer name!
Application.EnableEvents = True
Exit Sub
End If
Else

'Get customer name!
strMsg = "The current customer name is:" & vbLf & vbLf & _
"""EMPTY!""" & vbLf & vbLf & _
"Add a customer name:"

'Force add customer name add!
myGetCustNm:
strCustNm = InputBox(strMsg, "Add Customer Name!", "")

If strCustNm = "" Then GoTo myGetCustNm
End If

'Load customer name!
Sheets("Carolina Fireworks Order Form").Range("C7").Value = strCustNm
Application.EnableEvents = True
Exit Sub

myErr:
'GoTo Error routine!
Call myErrHandler(Err)
End Sub

Sub myCloseCode()
'Standard module code, like: Module1.
Dim strDate$, strCustomer$, strFileNm$, strMsg$, myUpDate$

Application.EnableEvents = False
On Error GoTo myErr

'Test for Save option or Exit without saving?
strMsg = "Save this file before closing?"

myUpDate = MsgBox(strMsg, vbQuestion + vbYesNo, "Save Now?")

'Chose "Yes" button!
If myUpDate = 6 Then GoTo mySave

'Chose "No" button!
If myUpDate = 7 Then
Application.EnableEvents = True
Exit Sub
End If

mySave:
'Build file name!
strDate = DatePart("m", Date) & "-" & _
DatePart("d", Date) & "-" & _
Right(DatePart("yyyy", Date, vbUseSystemDayOfWeek, vbUseSystem), 4)

strCustomer = Sheets("Carolina Fireworks Order Form").Range("C7").Value

strFileNm = "\\Owner-hp\Users\Public\Customers\" & strCustomer & "-" & strDate & ".xlsm"

'Save current file!
ActiveWorkbook.SaveAs Filename:=strFileNm
Application.EnableEvents = True
ActiveWorkbook.Close
Exit Sub

myErr:
'GoTo Error routine!
Call myErrHandler(Err)
Application.EnableEvents = True
End Sub

Private Sub myErrHandler(myErr As ErrObject)
'Standard module code, like: Module1.
'Error Trap Routine!
Dim myMsg$

'Build Error Message!
myMsg = "Error Number : " & Str(myErr.Number) & vbLf & _
"Error Location: " & myErr.Source & vbLf & _
"Error Description: " & myErr.Description & vbLf & vbLf & _
"Context: " & myErr.HelpContext & vbLf & _
"Help File: " & myErr.HelpFile
'Show Error Message!

MsgBox myMsg & vbLf & vbLf & _
"Use the ""Help"" button for more information, on this ERROR!", _
vbCritical + vbMsgBoxHelpButton, _
Space(3) & "Error!", _
myErr.HelpFile, _
myErr.HelpContext
End Sub

模块 2：

Sub CopyBO()
'Copy cells of cols A,B,D from rows containing "BO" in
'col I of the active worksheet (source sheet) to cols
'A,B,D of Sheet2 (destination sheet)
Dim DestSheet        As Worksheet
Set DestSheet = Worksheets("Back Order")

Dim sRow       As Long     'row index on source worksheet
Dim dRow       As Long     'row index on destination worksheet
Dim sCount     As Long
sCount = 0
 For sRow = 1 To 65536
   'use pattern matching to find "BO" anywhere in cell
   If Cells(sRow, "I") Like "*BO*" Then
      sCount = sCount + 1
        'copy cols A,B, D
      Cells(sRow, "A").Copy Destination:=DestSheet.Cells(sRow, "A")
      Cells(sRow, "B").Copy Destination:=DestSheet.Cells(sRow, "B")
      End If
Next sRow

MsgBox sCount & " Back Ordered rows copied", vbInformation, "Transfer Done"
End Sub
4

1 回答 1

0

下面的代码将在调用Back Order过程时创建工作表的副本。CopyBO

  Sub CopyBO()
    'Copy cells of cols A,B,D from rows containing "BO" in
    'col I of the active worksheet (source sheet) to cols
    'A,B,D of Sheet2 (destination sheet)
        Dim DestSheet As Worksheet
        Set DestSheet = Worksheets("Back Order")
        Dim n_Wkb As Workbook    ' new workbook
        Dim strFileNm As String

        Dim sRow As Long    'row index on source worksheet
        Dim dRow As Long    'row index on destination worksheet
        Dim sCount As Long
        sCount = 0
        For sRow = 1 To 65536
            'use pattern matching to find "BO" anywhere in cell
            If Cells(sRow, "I") Like "*BO*" Then
                sCount = sCount + 1
                'copy cols A,B, D
                Cells(sRow, "A").Copy Destination:=DestSheet.Cells(sRow, "A")
                Cells(sRow, "B").Copy Destination:=DestSheet.Cells(sRow, "B")
            End If
        Next sRow


        If sCount > 0 Then
            DestSheet.Copy
            Set n_Wkb = ActiveWorkbook

            ' Get the file path
            strCustomer = ThisWorkbook.Sheets("Carolina Fireworks Order Form").Range("C7").Value
            strFileNm = "\\Owner-hp\Users\Public\Customers\" & strCustomer
            strFileNm = strFileNm & Format(Now(), "DD-MM-YY hh.mm.ss") & ".xlsx"

            'save
            n_Wkb.SaveAs strFileNm
            n_Wkb.Close

        End If


        MsgBox sCount & " Back Ordered rows copied", vbInformation, "Transfer Done"
    End Sub
于 2013-05-28T00:52:32.130 回答