Excel VBA Course

(35% Sale Ends Jan. 26)

Excel VBA Course - From Beginner to Expert

200+ Video Lessons
50+ Hours of Video
200+ Excel Guides

Become a master of VBA and Macros in Excel and learn how to automate all of your tasks in Excel with this online course. (No VBA experience required.)

View Course (35% Discount)

Using VBA to auto enter data added on one sheet to another when multiple conditions are met

I have uploaded an example workbook. I am looking to get the infromation in the yellow colored cells at the bottom of the "DATA" worksheet to automaticaly copy to the sheet for the cart number specified in the blue colored cell and shelf specified by the green colored cell, at the first empty row for the customer shown in the purple colored cell. laycielee Nov 20, '20 at 8:50 am
Excel VBA Course - From Beginner to Expert

200+ Video Lessons 50+ Hours of Instruction 200+ Excel Guides

Become a master of VBA and Macros in Excel and learn how to automate all of your tasks in Excel with this online course. (No VBA experience required.)

(35% Sale Ends Jan. 26)


Selected Answer

All of the code below goes into the codesheet of your ENTERED DATA tab. Then save the workbook in XLSM format. You may like to use the attached workbook for learning your way with this code.

Private Enum Ned                ' worksheet "Entered Data"
    ' 120
    NedFirstDataRow = 2         ' change to suit
    NedCust = 1                 ' Columns: 1 = Column A
    NedPart                     '          2 = Column B
    NedRev                      '          No assigned value means "previous + 1"
End Enum

Private Enum Nct                ' worksheets "Cart x"
    ' 120
    NctPart                     ' first enum without assigned value = 0
    NctShelfRow = 1
End Enum

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 120

    Dim Trigger     As Range                ' the range to which this proc responds
    Dim Rl          As Long                 ' last used row
    Dim Arr         As Variant              ' the entire entry row

    Rl = Cells(Rows.Count, NedCust).End(xlUp).Row
    Set Trigger = Range(Cells(NedFirstDataRow, NedCust), Cells(Rl, NedShelf))
    If Not Application.Intersect(Target, Trigger) Is Nothing Then
        ' prevent changes made by this procedure from
        ' triggering another call of this procedure
        Application.EnableEvents = False
        With Target.Cells(1)                ' process only the first cell
            ' this test imposes restrictions:
            ' the 6 columns must be contiguous,
            ' Shelf must be last and no other entries in the row:-
            ' No action until all cells are filled
            If WorksheetFunction.CountA(Rows(.Row)) = NedShelf Then
                If (.Column = NedCust) Then
                    ' don't change the Customer name last
                    MsgBox "You can't change the Customer's name for this entry.", _
                           vbInformation, "Entry already posted"
                    Arr = Trigger.Rows(.Row - NedFirstDataRow + 1).Value
                    WriteCartEntry Arr
                End If
            End If
        End With
        Application.EnableEvents = True
    End If
End Sub

Private Sub WriteCartEntry(Arr As Variant)
    ' 120

    Const Cart          As String = "Cart "         ' with a trailing space

    Dim Ws              As Worksheet                ' CART sheet
    Dim Clm             As Long                     ' target column in CART
    Dim Rt              As Long                     ' target row in Cart

    On Error Resume Next
    Set Ws = Worksheets(Cart & CStr(Arr(1, NedCart)))
    If Err Then
        MsgBox "The worksheet " & Chr(34) & Cart & CStr(Arr(1, NedCart)) & _
               """ doesn't exist.", vbInformation, "Missing worksheet"
        On Error GoTo 0
        Clm = EntryColumn(Arr, Ws)
        If Clm = 0 Then AppendColumnSet Arr, Ws
        Rt = EntryRow(Arr(1, NedPart), Clm, Ws)
        If Rt = 0 Then
            Rt = Ws.Cells(Ws.Rows.Count, Clm).End(xlUp).Row + 1
            If WorksheetFunction.CountA(Ws.Rows(Rt)) = 0 Then Rt = AddCartRow(Ws)
        End If
        With Ws.Rows(Rt)
            .Cells(Clm + NctPart).Value = Arr(1, NedPart)
            .Cells(Clm + NctRev).Value = Arr(1, NedRev)
            .Cells(Clm + NctQty).Value = Arr(1, NedQty)
        End With
    End If
End Sub

Private Function EntryColumn(Arr As Variant, _
                             Ws As Worksheet) As Long
    ' 120
    ' return 0 if not found

    Dim Rng         As Range                ' range to search in
    Dim Crit        As Variant              ' search criterium
    Dim Fnd         As Range                ' cell where match was found
    Dim FirstFound  As Long

    Set Rng = Ws.Rows(NctShelfRow)
    Crit = CartShelfId(Arr(1, NedShelf))
    With Rng
        Set Fnd = .Find(Crit, .Cells(.Cells.Count), xlValues, xlWhole, xlByRows, xlNext, False)
        If Not Fnd Is Nothing Then
            FirstFound = Fnd.Column
                ' both, Shelf and Customer IDs must match
                If Ws.Cells(NctCustRow, Fnd.Column).Value = CartCustId(Arr(1, NedCust)) Then
                    EntryColumn = Fnd.Column
                    Exit Do
                End If
                Set Fnd = .FindNext(Fnd)
            Loop While Not Fnd Is Nothing
        End If
    End With
End Function

Private Function EntryRow(ByVal Part As String, _
                          ByVal Clm As Long, _
                          Ws As Worksheet) As Long
    ' 120
    ' return 0 if not found

    Dim Fnd         As Range                ' cell where match was found

    Set Fnd = Ws.Columns(Clm).Find(Part)
    If Not Fnd Is Nothing Then EntryRow = Fnd.Row
End Function

Private Function CartCustId(ByVal Id As String) As String
    ' 120

    Dim Fun         As String           ' function return value

    Fun = Id
    If InStr(Fun, "(") Then
        Fun = Mid(Fun, 2, Len(Fun) - 2)
    End If
    CartCustId = UCase(Fun)
End Function

Private Function CartShelfId(ByVal Id As String) As String
    ' 120

    Dim Fun         As String           ' function return value

    Fun = Id
    If InStr(1, Fun, "shelf", vbTextCompare) = 0 Then
        If Val(Fun) Then Fun = Fun & " shelf"       ' with leading space
    End If
    If InStr(Fun, ":") = 0 Then Fun = Fun & ":"
    CartShelfId = UCase(Fun)
End Function

Private Sub AppendColumnSet(Arr As Variant, _
                            Ws As Worksheet)
    ' 120

    Dim Ct          As Long                 ' target column
    Dim Rng         As Range

    With Ws
        Ct = .Cells(NctCapsRow, .Columns.Count).End(xlToLeft).Column + 1
        .Range(.Columns(1), .Columns(NctQty + 1)).Copy Destination:=.Cells(1, Ct)
        Set Rng = .Range(.Cells(NctFirstDataRow, Ct), _
                         .Cells(.Rows.Count, Ct + NctQty).End(xlUp))
        .Cells(NctShelfRow, Ct).Value = CartShelfId(Arr(1, NedShelf))
        .Cells(NctCustRow, Ct).Value = CartCustId(Arr(1, NedCust))
    End With
End Sub

Private Function AddCartRow(Ws As Worksheet) As Long
    ' 120
    ' return the number of the added row

    Dim R           As Long                     ' loop counter: row

    With Ws
        R = .Cells(.Rows.Count, NedCust).End(xlUp).Row
            R = R + 1
            If WorksheetFunction.CountA(.Rows(R)) = 0 Then Exit Do
        .Rows(R - 1).Copy
        .Rows(R).PasteSpecial xlPasteFormats
    End With
    Application.CutCopyMode = False
    AddCartRow = R
End Function

Very broadly speaking, when you add a new item in the ED sheet the procedure runs but takes no action if not all components of a row have been entered. It refuses to take action if the customer name is changed after, presumably, an entry in a CART sheet has already been made. In fact, this proibition should be extended to the shelf posiution as well.

I thought your arrangement for shelves and customer names isn't quite what it should be but went with the present arrangement. That leads to a new set of columns being added if Shelf and Customer don't match. Note that you can change existing entries, except for the customer name.

Inconsisting spelling of customer names (with and without parenthesis) and shelf IDs required some unnecessary programming but the functions are all there now - ready to become obsolete when you streamline your project. The long and the short is that I did the programming but you will need to do the testing. The program is quite complex and there are niches neither one of us may have thought about. In order to test successfully you will have to understand the program. Toward that end I added some comments which I commend to your attention. Make sure you fully understand them.

Good luck!



I placed the code in the "ENTERED DATA" sheet and when running the "test" entry, I recieved an error code when entering the part number on the on the entered data sheet telling me The worksheet "Cart" does not exist? Does this have to do with the fact that I have multiple worksheets (CART 1, CART 2, CART 3 AND CART 4)? Or is this a capitalization error? 
laycielee (rep: 2) Nov 23, '20 at 12:01 pm
The code works perfect on the example workbook I uploaded, however my actual workbook consits of 4 "cart sheets" (CART 1, CART 2, CART 3 and CART 4). I also have roundabout 20+/- 1 or 2 customers with actual customer names. I can not post that sheet here due to confidentiality contracts with customers.
laycielee (rep: 2) Nov 23, '20 at 12:11 pm
The code won't execute until all six entries have been made. If you entered an Cart that doesn't exist it should alert you. If you don't want the code to fire, leave the Cart column blank. You can create many entries and fill in the Cart after you have set up the sheet.
Customers and Shelves are different. The code creates them if they don't exist.
Variatus (rep: 4874) Nov 23, '20 at 6:46 pm
Add to Discussion

Answer the Question

You must create an account to use the forum. Create an Account or Login