无法将 2 个宏合并在一起

Question

现在做什么： 有2张“申请表”“价格表” 当我在价格表的 D 列中输入值并点击按钮生成文件时，D 列和 F 列被复制并粘贴到 G27 和 H27 的申请表中。

我想做的是： 制作另一个名为“合并”的按钮，当我点击它时，它应该复制价格表中的总量“G183”并将其粘贴到申请表的 G27 中。

错误：

当我单击生成文件时，它正在正确执行。但是，当我单击清除值并在价格表的 D 列中再次输入值并单击合并时，它并没有复制和粘贴总金额。给我错误 #REF!。我尝试给出单元格的值，但是一旦我点击清除按钮，它就会擦除上面选择的公式并向我显示上述错误。

还有人可以帮助我“当我单击合并按钮时如何在列 H27 中放置一个恒定的 $1 值。 所以基本上，当我单击合并按钮时，它应该从价格表中复制总金额“G183”，并将其以请购单的形式添加到 G27 中，并在 H27 中保持不变的 1 美元。

Option Explicit

Private Sub CommandButton1_Click()

Worksheets("Requisition Form").Range("A27:H34").ClearContents
 Dim wb As Workbook
    Dim wsData As Worksheet
    Dim wsDest As Worksheet
    Dim rDest As Range

    Set wb = ActiveWorkbook
    Set wsData = wb.Worksheets("PRICE SCHEDULE")
    Set wsDest = wb.Worksheets("Requisition Form")
    Set rDest = wsDest.Cells(wsDest.Rows.Count, "G").End(xlUp).Offset(1)
    If rDest.Row < 26 Then Set rDest = wsDest.Range("G27")

    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    With wsData.Range("D14:F" & wsData.Cells(wsData.Rows.Count, "D").End(xlUp).Row)
        If .Row < 13 Then GoTo CleanExit     'No data
        .AutoFilter 1, ">0", xlFilterValues 'Filter on column C for values >0
        Intersect(.Worksheet.Range("D:D,F:F"), .Offset(1)).Copy 'Copy filtered values in columns C and E only
        rDest.PasteSpecial xlPasteValues    'Paste values only to destination
        .AutoFilter 'Clear filter
    End With

CleanExit:
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

Sub Clearcells()
Worksheets("PRICE SCHEDULE").Activate
Range("D15", "D181").Clear
Sheets("PRICE SCHEDULE").Select
End Sub

Sub Consolidate()

Worksheets("PRICE SCHEDULE").Range("G183").Select
Worksheets("PRICE SCHEDULE").Range("G183").Copy

Worksheets("Requisition Form").Activate

Worksheets("Requisition Form").Range("G27").Select
Worksheets("Requisition Form").Paste

Worksheets("PRICE SCHEDULE").Activate
Worksheets("PRICE SCHEDULE").Range("G27").Select

Application.CutCopyMode = False

End Sub

Answer 1

按分配复制值

Sub Consolidate()

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Sheets("Price Schedule")
    Dim dws As Worksheet: Set dws = wb.Sheets("Requisition Form")
   
    dws.Range("G27").Value = sws.Range("G183").Value
    dws.Range("H27").Value = "$1"

End Sub

Sub ClearCells()

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Sheets("Price Schedule")
    
    ws.Range("D15:D181").ClearContents
    'ws.Select ' only if it's necessary

End Sub

Private Sub CommandButton1_Click()
    On Error GoTo ClearError ' start error-handling routine

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Sheets("Price Schedule")
    If sws.AutoFilterMode Then sws.AutoFilterMode = False ' turn off AutoFilter
    Dim slCell As Range: Set slCell = sws.Cells(sws.Rows.Count, "D").End(xlUp)
    If slCell.Row < 15 Then Exit Sub ' no data; 14 are the headers
    
    ' Reference the table range (has headers)
    Dim srg As Range: Set srg = sws.Range("D14", sws.Cells(slCell.Row, "F"))
    ' Reference the data range (no headers) to be used with 'Intersect'.
    Dim sdrg As Range: Set sdrg = srg.Resize(srg.Rows.Count - 1).Offset(1)
    
    ' See the addresses in the Immediate window (Ctrl+G).
    Debug.Print "Table: " & srg.Address, "Data: " & sdrg.Address
    
    ' Destination
    
    Dim dws As Worksheet: Set dws = wb.Sheets("Requisition Form")
    ' This makes no sense since later the first cell could possibly be in row 27
    ' i.e. the range contains column 'G'.
    dws.Range("A27:H34").ClearContents
    Dim dfCell As Range
    Set dfCell = dws.Cells(dws.Rows.Count, "G").End(xlUp).Offset(1)
    If dfCell.Row < 27 Then Set dfCell = dws.Range("G27")

    ' Copy
    
    With Application ' turn off settings
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    srg.AutoFilter 1, ">0", xlFilterValues ' filter on column D
    Intersect(sws.Range("D:D,F:F"), sdrg).Copy ' copy from columns D and F only
    dfCell.PasteSpecial xlPasteValues ' paste values only
    srg.AutoFilter ' turn off auto filter

CleanExit: ' Exit Routine
    With Application
        If Not .EnableEvents Then ' settings are turned off; turn them on
            .EnableEvents = True
            .Calculation = xlCalculationAutomatic
            .ScreenUpdating = True
        'Else ' settings are still turned on; do nothing
        End If
    End With
    Exit Sub ' don't forget this!
ClearError: ' continue error-handling routine
    Debug.Print "Run-time error '" & Err.Number & vbLf & Err.Description
    Resume CleanExit ' redirect to exit routine
End Sub