Question

我使用Excel为我公司制作发票系统。对于使用该程序的其他一些员工，我必须对其进行“虚拟证明”。我使用几个代码来使它成功。我有两张：卡罗莱纳州烟花订购表和延期订单。 卡罗莱纳烟花订单表上有一个宏，可以将任何单元格复制到延期订单表格（这是卡罗莱纳烟花订单表格的精确副本，但在C7中除外客户名称自动显示客户名称和BO）。

我有一个代码可以自动将文件保存到具有C7（客户名称）和当前日期的特定文件夹中。有没有办法我可以添加一个代码，如果我按下宏按钮复制BO单元格，它将自动保存延期订单表格，文件名C7和当前日期？然后，当我点击x按钮时，我的其他代码将自动保存Carolina Fireworks订购单（表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

Answer 1

下面的代码会在调用过程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

使用编码在同一工作簿中保存2个不同的工作表

1 个答案: