Sub-Branch Account Document Confirmation

Thursday, November 17, 2016

စာသိမ္းရက္(18 NOV 2016)

Posted by Unknown at 12:11 AM No comments:

Email This BlogThis!Share to X Share to Facebook Share to Pinterest

Home

Subscribe to: Comments (Atom)

Document Confirmation

Blog Archive

November (1)

About Me

Unknown

View my complete profile

Blog Archive

▼ 2016 (1)
- ▼ November (1)
  - စာသိမ္းရက္(18 NOV 2016)

DATA BOX

te Sub Worksheet_Change(ByVal Target As Range) Dim ctgCount, UniqueCount As Long Dim subCategory() As String Dim subItems As String Dim myItems, ValidationFormula As String Dim ArrayItemCount As Long Dim UniqueItemMatch As Boolean myItems = "" If Not Application.Intersect(Target, Range("C3:C12")) Is Nothing Then If Target.Value = "" Then Target.Offset(0, 1).Clear Exit Sub End If ctgCount = Application.WorksheetFunction.CountIf(Sheet2.Range("C3:C22"), Target.Value) - 1 ReDim subCategory(ctgCount) For Each cel In Sheets("Sheet2").Range("C3:C22") UniqueItemMatch = False If cel.Value = Target.Value Then For i = 0 To ctgCount If cel.Offset(0, 1).Value = subCategory(i) Then UniqueItemMatch = True Exit For Else UniqueItemMatch = False End If Next i If UniqueItemMatch = False Then UniqueCount = 0 For j = 0 To UBound(subCategory()) If subCategory(j) <> "" Then UniqueCount = UniqueCount + 1 Next j subCategory(UniqueCount) = cel.Offset(0, 1).Value End If End If Next cel For k = 0 To UBound(subCategory()) If subCategory(k) <> "" Then myItems = myItems & ", " & subCategory(k) ValidationFormula = Mid(Trim(myItems), 2, Len(Trim(myItems)) - 1) Next k Target.Offset(0, 1).Select Selection.Clear With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=ValidationFormula .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = True End With End If '************** For 2nd sub Items *************************************************************** If Not Application.Intersect(Target, Range("D3:D12")) Is Nothing Then If Target.Value = "" Then Target.Offset(0, 1).Clear Exit Sub End If ctgCount = Application.WorksheetFunction.CountIf(Sheet2.Range("D3:D22"), Target.Value) - 1 ReDim subCategory(ctgCount) For Each cel In Sheets("Sheet2").Range("D3:D22") UniqueItemMatch = False If cel.Value = Target.Value Then For i = 0 To ctgCount If cel.Offset(0, 1).Value = subCategory(i) Then UniqueItemMatch = True Exit For Else UniqueItemMatch = False End If Next i If UniqueItemMatch = False Then UniqueCount = 0 For j = 0 To UBound(subCategory()) If subCategory(j) <> "" Then UniqueCount = UniqueCount + 1 Next j subCategory(UniqueCount) = cel.Offset(0, 1).Value End If End If Next cel For k = 0 To UBound(subCategory()) If subCategory(k) <> "" Then myItems = myItems & ", " & subCategory(k) ValidationFormula = Mid(Trim(myItems), 2, Len(Trim(myItems)) - 1) Next k Target.Offset(0, 1).Select Selection.Clear With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=ValidationFormula .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = True End With End If End Sub

Ethereal theme. Powered by Blogger.