View Single Post
 
Old 12-19-2017, 11:11 PM
NoSparks NoSparks is offline Windows 7 64bit Office 2010 64bit
Excel Hobbyist
 
Join Date: Nov 2013
Location: British Columbia, Canada
Posts: 831
NoSparks is just really niceNoSparks is just really niceNoSparks is just really niceNoSparks is just really niceNoSparks is just really nice
Default

Okay, maybe this will work for you...

rename current table "State" to "_21000_State_Program_Travel"
rename current table "Sheet23" to "_26062_Supplies"
now the name of the associated tables can be derived from the sheet names.

The formulas within the tables refer to things by referencing sheet cell locations as opposed to table locations so I left the tables as-is with all those empty hidden rows.
Not adding new rows to the tables, instead start at the header row and step down column E to find the first empty cell.
You might need to change that to a different column that will be populated for every record.

Put this in the ThisWorkbook module and give it a shot
Code:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

'limit to sheets whose name starts with 5 digits
 If Not IsNumeric(Left(Sh.Name, 5)) Then Exit Sub
'limit to single cell in column K
 If Target.Count > 1 Or Target.Column <> 11 Then Exit Sub
 
    Dim ray As Variant
    Dim oLo As ListObject
    Dim destTable As String
    Dim HderRow As Long
    Dim i As Integer
    
If UCase(Target.Value) = "NO" Then
    destTable = "_" & Replace(Sh.Name, " ", "_")
    ray = Split(Cells(Target.Row, "B").Value & "|" & Cells(Target.Row, "D").Value & "|" & Cells(Target.Row, "J").Value, "|")
End If

Application.ScreenUpdating = False

With Sheets("MONTHLY GOE RECONCILIATION")
    .Select
    .ListObjects(destTable).HeaderRowRange.Select
    HderRow = Selection.Row
    For i = 1 To 99
        If IsEmpty(.Cells(HderRow + i, 5)) Then Exit For
    Next i
    Application.EnableEvents = False
    .Cells(HderRow + i, 2).Resize(, 3).Value = ray
    Application.EnableEvents = True
End With

Sh.Select

Application.ScreenUpdating = True

End Sub
Reply With Quote