Copy sent to "History Sheet" everytime the Active X button is pressed.

Hello,

I am looking for cells B18, C18, and E18 on Sheet 1 to be sent to the History sheet to the first available open row when the Box Count button is pressed. The first available row starts at row 3 and moves down depending on how many entries are already on the page. Any help would be appreciated. I'm not very good with this part of vba coding.


Thanks


The code is in module 1 as Sub Boxcount. Here is the code.

Sub BoxCount()
    Dim Qty1 As Double
        
        Qty1 = ThisWorkbook.Worksheets(1).Range("C18").Value - _
        ThisWorkbook.Worksheets(1).Range("B18").Value
        
    ThisWorkbook.Worksheets(1).Range("C18").Value = Qty1
    
    'Clear cell after subtraction
        ThisWorkbook.Worksheets(1).Range("B18").Value = ""
    'Message Box too order boxes when below 1500
    If ThisWorkbook.Worksheets(1).Range("C18").Value <= 1500 Then
    MsgBox ("Tell Chris to order more boxes")
    End If
End Sub

Is anybody awake this morning that is good with this sort of thing? I tried to figure out how it was being posted to the history sheet by my other command buttons, but I had no luck.

Okay, I made one change to the range I was sending to the history sheet. I just unmerged a cell, so the range is now B:18 to D:18.

I wrote a code that is doing what I asked, but it doesn't work like the other code that was written for me. This code flashes to the "History Sheet" and then back to "Sheet 1". That does not with the original coding in the Inventory active x button.

If anyone can modify this code so it is more efficient without the quick flash to copy and paste the information to the "History Sheet", I would be interested in learning.

Thank you for any help in advance.

Final Code for now

Sub BoxCount()
    Dim Qty1 As Double
        
        Qty1 = ThisWorkbook.Worksheets(1).Range("C18").Value - _
        ThisWorkbook.Worksheets(1).Range("B18").Value
        
    ThisWorkbook.Worksheets(1).Range("C18").Value = Qty1
    
    ' Highlight cell Red if the value is less than order quantity
    
    If ThisWorkbook.Worksheets(1).Range("C18").Value <= 1500 Then
    ThisWorkbook.Worksheets(1).Range("C18").Interior.Color = RGB(250, 0, 0)
    End If
    
    ' Send copy to History Sheet
    
    ThisWorkbook.Worksheets(1).Range("B18:D18").Copy
    ThisWorkbook.Worksheets(6).Activate
    erow = Worksheets(6).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    ActiveSheet.Paste Destination:=Worksheets(6).Rows(erow)
    Worksheets(1).Activate
    Application.CutCopyMode = False
        
    'Clear cell after subtraction
        ThisWorkbook.Worksheets(1).Range("B18").Value = ""
        
    
    'Message Box too order boxes when below 1500
    If ThisWorkbook.Worksheets(1).Range("C18").Value <= 1500 Then
    MsgBox ("Tell Chris to order more boxes")
    End If
    
End Sub

This is way to easy. See the highlighed fonts added to the code.

Sub BoxCount()
    Dim Qty1 As Double
        Application.ScreenUpdating = False
        Qty1 = ThisWorkbook.Worksheets(1).Range("C18").Value - _
        ThisWorkbook.Worksheets(1).Range("B18").Value
        
    ThisWorkbook.Worksheets(1).Range("C18").Value = Qty1
    
    ' Highlight cell Red if the value is less than order quantity
    
    If ThisWorkbook.Worksheets(1).Range("C18").Value <= 1500 Then
    ThisWorkbook.Worksheets(1).Range("C18").Interior.Color = RGB(250, 0, 0)
    End If
    
    ' Send copy to History Sheet
    
    ThisWorkbook.Worksheets(1).Range("B18:D18").Copy
    ThisWorkbook.Worksheets(6).Activate
    erow = Worksheets(6).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    ActiveSheet.Paste Destination:=Worksheets(6).Rows(erow)
    Worksheets(1).Activate
    Application.CutCopyMode = False
        
    'Clear cell after subtraction
        ThisWorkbook.Worksheets(1).Range("B18").Value = ""
        
    Application.ScreenUpdating = True
    'Message Box too order boxes when below 1500
    If ThisWorkbook.Worksheets(1).Range("C18").Value <= 1500 Then
    MsgBox ("Tell Chris to order more boxes")
    End If
    
End Sub

Sub BoxCount()
    
    ' Send copy to History Sheet
    
    Dim c As Long
    Dim HistWks As Worksheet
    Dim LastEntry As Range
    Dim Rng As Range
    Dim SizeWks As Worksheet
    Dim Wks As Worksheet
    
        Set Wks = Sheet1
        Set HistWks = Worksheets("History Sheet")
        
        Set Rng = HistWks.Range("A3:C3")
        
        c = Rng.Columns.Count
        Set LastEntry = HistWks.Cells(Rows.Count, "A").End(xlUp)
        
        If LastEntry.Row >= 3 Then Set Rng = LastEntry.Offset(1, 0)
        
         
            With ActiveCell
                Rng.Resize(1, c).Value = Wks.Cells(.Row, "B").Resize(1, c).Value
                On Error Resume Next
                     Set SizeWks = Worksheets(Wks.Cells(.Row, "B").Value)
                    If Err <> 0 Then
                        MsgBox "Please Select a Row."
                        Exit Sub
                    End If
                On Error GoTo 0
        
            End With
         
    
    
    Dim Qty1 As Double
        
        Qty1 = ThisWorkbook.Worksheets(1).Range("C18").Value - _
        ThisWorkbook.Worksheets(1).Range("B18").Value
        
    ThisWorkbook.Worksheets(1).Range("C18").Value = Qty1
    
    ' Highlight cell Red if the value is less than order quantity
    
    If ThisWorkbook.Worksheets(1).Range("C18").Value <= 1500 Then
    ThisWorkbook.Worksheets(1).Range("C18").Interior.Color = RGB(250, 0, 0)
    End If
    
    
    'Clear cell after subtraction
        ThisWorkbook.Worksheets(1).Range("B18").Value = ""
        
    
    'Message Box too order boxes when below 1500
    If ThisWorkbook.Worksheets(1).Range("C18").Value <= 1500 Then
    MsgBox ("Tell Chris to order more boxes")
    End If
    
End Sub

I have been working on another way to send it to the "History Sheet" similar to the way it was sent with the other Active x buttons but it keeps giving me an error and tripping out the please select a row message.

When I am selected in any of the three boxes it will send the copy to the history sheet, but when I am selected somewhere else on the sheet it will not send a copy to the history sheet.

Either way the new code keeps stopping on the bolded area.

That's because the code requires the active cell to be one of the cells that contain the dropdown box in column A.

So, yes, if the active cell is other than that, the code 'fails' and shows the message box to select a size or to select a row (depending on the button pressed).

I believe your problem lies with the highlighted section of the code below. The line 'With.ActiveCell' needs to be changed.

Sub UpdateHistory()

    Dim c As Long
    Dim HistWks As Worksheet
    Dim LastEntry As Range
    Dim Qty As Double
    Dim Qyt2 As Double
    Dim r As Long
    Dim Rng As Range
    Dim SizeWks As Worksheet
    Dim Wks As Worksheet
    
        Set Wks = Sheet1
        Set HistWks = Worksheets("History Sheet")
        
        Set Rng = HistWks.Range("A3:H3")
        
        c = Rng.Columns.Count
        Set LastEntry = HistWks.Cells(Rows.Count, "A").End(xlUp)
        
        If LastEntry.Row >= 3 Then Set Rng = LastEntry.Offset(1, 0)
        
    
          ' Get the row and column of the quantity on the size sheet.
            With ActiveCell

'rest of code ....

Dim c As Long
    Dim HistWks As Worksheet
    Dim LastEntry As Range
    Dim Rng As Range
    Dim SizeWks As Worksheet
    Dim Wks As Worksheet

        Set Wks = Sheet1

        Set HistWks = Worksheets("History Sheet")
        
        Set Rng = HistWks.Range("A3:C3")
        
        c = Rng.Columns.Count
        Set LastEntry = HistWks.Cells(Rows.Count, "A").End(xlUp)
        
        If LastEntry.Row >= 3 Then Set Rng = LastEntry.Offset(1, 0)
                
            With ActiveCell
                Rng.Resize(1, c).Value = Wks.Cells.Range("B18").Resize(1, c).Value
            End With

This is the code I have come up with for now. It does work, but it will work from anywhere the selected cell is. I cannot find a working error code to let me know the selected cell is not one of the three cell B18, C18, or D18....

There are two different codes here for copy and pasting to another sheet. Neither one are quite right yet, so I am looking for the copy and paste experts.

With the first one,

ActiveSheet.Paste Destination:=Worksheets(6).Rows(erow)

this part of the code needs to paste special and just transfer the values. Right now it is still carrying the original format and I would like it to just transfer the values.

With the second one, I still haven't found a way for the code to make sure it is selected on the group of cells copying to the History Sheet.

Add the highlighted part to the end of your code;
I believe this will do what you need.

ActiveSheet.Paste Destination:=Worksheets(6).Rows(erow).PasteSpecial xlPasteValues

If that doesn't do everything you need, then try this;

ActiveSheet.Paste Destination:=Worksheets(6).Rows(erow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

I couldn't get either one of those codes to work this morning. I will investigate it more after work today.

Set Swks = Sheet1
    Set Hwks = ThisWorkbook.Worksheets("History Sheet")
    Set R1 = Swks.range("B18:D18")
    Set R2 = Hwks.range("A3:C3")
        
        C = R2.Columns.Count
        Set LastEntry = Hwks.Cells(Rows.Count, 1).End(xlUp)
        If R2.Row >= 3 Then Set R2 = LastEntry.Offset(1, 0)
                    R2.Resize(1, C).Value = R1.Resize(1, C).Value

This is the code I am using to copy my entry to the History Sheet in my workbook from sheet1. I am looking to find a way to identify the active cell or cells in range R1 to copy to the History Sheet or have a message box come up and say "please select row." It is likely I will add another small range underneath it (as shown on sheet1 in my example) so I will need to distinguish between the two.

Thanks for any help.

Originally Posted by Spreadlover

This is the final coding I came up with. Now I will be able to add other items to track on sheet1 as long as they are in the B, C, and D columns. Only the row selected will be active and I did not have to name a specific cell for the subtraction or the copying to the History Sheet.

Thanks for the help!!

Sub BoxCount3()
    Dim Rng As Range
    Dim C As Long
    Dim R0 As Range
    Dim R1 As Range
    Dim R2 As Range
    Dim Hwks As Worksheet
    Dim Swks As Worksheet
    Dim Wks As Worksheet
    Dim Qty1 As Double
    
        'message box Please select valid Row
        Set Swks = Sheet1
        Set R0 = Swks.Cells(ActiveCell.Row, 3)
            If R0.Value = "" Then
            MsgBox ("Please select valid Row")
                Exit Sub
            End If
            
        'message box enter valid quantity
        Set R1 = Swks.Cells(ActiveCell.Row, 2)
            If R1.Value = "" Then
            MsgBox ("Enter Valid Quantity")
                Exit Sub
            End If
        
        'Subtract quantity from Total
        Qty1 = R0.Value - R1.Value
        R0.Value = Qty1
    
    'Send copy to Histor Sheet
    Set Hwks = ThisWorkbook.Worksheets("History Sheet")
    Set R2 = Hwks.Range("A3:C3")
        
        C = R2.Columns.Count
        Set LastEntry = Hwks.Cells(Rows.Count, 1).End(xlUp)
        If R2.Row >= 3 Then Set R2 = LastEntry.Offset(1, 0)
                    R2.Resize(1, C).Value = R1.Resize(1, C).Value
                    
    'Clear cell after subtraction
    R1.Value = ""
                    
    ' Highlight cell Red if the box value is less than order quantity
    If ThisWorkbook.Worksheets(1).Range("C18").Value <= 1500 Then
    ThisWorkbook.Worksheets(1).Range("C18").Interior.Color = RGB(250, 0, 0)
    Else: ThisWorkbook.Worksheets(1).Range("C18").Interior.Color = xlNone
    End If
        
    'Message Box to order boxes when below 1500
    If ThisWorkbook.Worksheets(1).Range("C18").Value <= 1500 Then
    MsgBox ("Tell Chris to order more boxes")
    End If
    
    ' Highlight cell Red if the skid value is less than order quantity
    If ThisWorkbook.Worksheets(1).Range("C21").Value <= 60 Then
    ThisWorkbook.Worksheets(1).Range("C21").Interior.Color = RGB(250, 0, 0)
    Else: ThisWorkbook.Worksheets(1).Range("C21").Interior.Color = xlNone
    End If
        
    'Message Box to order skids when below 1500
    If ThisWorkbook.Worksheets(1).Range("C21").Value <= 60 Then
    MsgBox ("Tell Chris to order more Skids")
    End If
    
    

End Sub

If you look in module 3, you will see this code and a whole other way to copy and paste to the another sheet.

A few things were change around since I started this thread, but this is the final code I came up with.