Welcome, guest! Login / Register - Why register?
Psst.. new poll here.
Psst.. new forums here.
Microsoft is blocking us again (TY IP Reputation!) so just use oauth login instead. :)

Paste

Pasted as VBScript by Tom ( 5 years ago )
Public Override As String
Public Sub Call1()
Dim Inp As Worksheet, Tree As Worksheet
Dim I As Long
Set Inp = ThisWorkbook.Worksheets("Input Screen")
Set Tree = ThisWorkbook.Worksheets("Call Tree")
Inp.Activate
 If Inp.Range("J7").Value2 = "Main" Then
    Tree.Range("A2").Value2 = Inp.Range("D7").Value2
    AddRepo
    MsgBox ("Master Program " & Inp.Range("D3").Value2 & " was added to " & Tree.Cells(1, 1))
 ElseIf Inp.Range("J7").Value2 = "Sub" Then
    Set PFound = Tree.Range("A1:Z100").Find(What:=Inp.Range("D3").Value2, LookAt:=xlWhole)
    If PFound Is Nothing Then
     MsgBox ("Calling Program " & Inp.Range("D3").Value2 & " was not found.")
    Else
     For I = PFound.Row To 100
              
        If IsEmpty(Tree.Cells(I, PFound.Column + 1)) Then
          If Tree.Cells(I, PFound.Column).Value = Inp.Range("D3").Value2 Then
            Tree.Cells(I, PFound.Column + 1).Value = Inp.Range("D7").Value2
            AddRepo
            MsgBox ("Program added to: " & Tree.Cells(1, PFound.Column + 1))
            Exit For
          ElseIf CheckNotEmptyL(I, PFound.Column) Then
            Tree.Rows(I).Insert shift:=xlShiftDown
            Tree.Cells(I, PFound.Column + 1).Value = Inp.Range("D7").Value2
            AddRepo
            MsgBox ("Program added to: " & Tree.Cells(1, PFound.Column + 1))
            Exit For
          ElseIf CheckEmptyR(I, PFound.Column) Then
            'Set FindBlank = Range(FindEmptyB(I, PFound.Column))
            'Tree.Rows(I).Insert shift:=xlShiftDown
            Tree.Cells(I, PFound.Column + 1).Value = Inp.Range("D7").Value2
            AddRepo
            MsgBox ("Program added to: " & Tree.Cells(1, PFound.Column + 1))
            Exit For
          'Else
            'Tree.Cells(I, PFound.Column + 1).Value = Inp.Range("D7").Value2
            'AddRepo
            'MsgBox ("Program added to: " & Tree.Cells(1, PFound.Column + 1))
            'Exit For
          End If
        ElseIf IsEmpty(Tree.Cells(I + 1, PFound.Column)) = False Then
            Tree.Rows(I + 1).Insert shift:=xlShiftDown
        End If
     
     Next I
    End If
 End If
End Sub
Public Function CheckNotEmptyL(thisRow As Long, thisColumn As Long)
Set Tree = ThisWorkbook.Worksheets("Call Tree")
Dim j As Long
For j = thisColumn To 1 Step -1
    If IsEmpty(Tree.Cells(thisRow, j)) Then
       CheckNotEmptyL = "False"
    Else
       CheckNotEmptyL = "True"
       Exit For
    End If
Next j
End Function
Public Function CheckEmptyR(thisRow As Long, thisColumn As Long)
Set Tree = ThisWorkbook.Worksheets("Call Tree")
Dim k As Long
For k = thisColumn To 50
    If IsEmpty(Tree.Cells(thisRow, k)) Then
       CheckEmptyR = "True"
    Else
       CheckEmptyR = "False"
       Exit For
    End If
Next k
End Function
Public Function FindEmptyB(thisRow As Long, thisColumn As Long)
Set Tree = ThisWorkbook.Worksheets("Call Tree")
Dim k As Long
For k = thisRow + 1 To 100
    If IsEmpty(Tree.Cells(k, thisColumn + 1)) Then
       FindEmptyB = Tree.Cells(k, thisColumn + 1).Address
       Exit For
    End If
Next k
End Function


Sub AddRepo()

Dim Inp As Worksheet, Tree As Worksheet
Dim Cell As Range
Dim Result As String
Dim l As Long
Dim m As Long
Set Inp = ThisWorkbook.Worksheets("Input Screen")
Set Repo = ThisWorkbook.Worksheets("Program Repository")
Set PrgmFound = Repo.Range("A1:A200").Find(Inp.Range("D7").Value2)
If PrgmFound Is Nothing Then
    Override = "N"
AddPgm:
    If Override <> "Y" Then
        Set BFound = Repo.Range("A1:A200").Find("")
    Else
        Set BFound = PrgmFound
    End If
    Repo.Cells(BFound.Row, BFound.Column).Value = Inp.Range("D7").Value2
    Repo.Cells(BFound.Row, BFound.Column + 1).Value = Inp.Range("G7").Value2
    Repo.Cells(BFound.Row, BFound.Column + 2).Value = Inp.Range("D9:G10").Value2
    For l = 16 To 50
        For m = 2 To 4
            If m <> 4 And Inp.Cells(l, m) <> "" Then
                Result = Result & Trim(Inp.Cells(l, m)) & "-"
            Else
                Result = Result & Trim(Inp.Cells(l, m))
            End If
        Next m
        If Inp.Cells(l + 1, 2) <> "" Then
            Result = Result & vbNewLine
        End If
    Next l
    Repo.Cells(BFound.Row, BFound.Column + 3).Value = Result
Else
    UserForm1.Show
    If Override = "Y" Then
        GoTo AddPgm
    Else
        MsgBox ("Program not updated in Repository")
    End If
End If
End Sub

 

Revise this Paste

Your Name: Code Language: