Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Option Explicit
- Public Sub Worksheet_SelectionChange(ByVal Target As Range)
- If IsArray(Target.Value) Then Exit Sub
- Rem 1 main worksheet data range info
- Dim CntItms As Long: Let CntItms = Me.Range("B" & Rows.Count & "").End(xlUp).Row
- If Application.Intersect(Target, Me.Range("A2:A" & CntItms & "")) Is Nothing Then Exit Sub
- If Worksheets("DataSaladinValagationLists").Range("A" & Target.Row & "").Value <> "" Then Exit Sub
- Dim CntClms As Long: Let CntClms = Me.Cells.Item(1, Columns.Count).End(xlToLeft).Column
- Rem 2 make drop down list for this row
- Let Application.EnableEvents = False
- Me.Range("C" & Target.Row & "", Me.Cells.Item(Target.Row, CntClms)).SpecialCells(xlCellTypeConstants).Copy
- Let Application.EnableEvents = True
- Dim Dtaobj As Object
- Set Dtaobj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
- Dtaobj.GetFromClipboard: Dim strClip As String: Let strClip = Dtaobj.GetText()
- Let strClip = Left(strClip, Len(strClip) - 2)
- Application.CutCopyMode = False
- Dim strSptInDrpPlop() As String: Let strSptInDrpPlop() = Split(strClip, vbTab, -1, vbBinaryCompare)
- Dim UnEeks As String
- Dim Cnt As Long
- For Cnt = 0 To UBound(strSptInDrpPlop())
- If InStr(1, UnEeks, Trim(strSptInDrpPlop(Cnt)), vbBinaryCompare) = 0 And Not Trim(strSptInDrpPlop(Cnt)) = "" And Not strSptInDrpPlop(Cnt) = vbTab Then
- Let UnEeks = UnEeks & Trim(strSptInDrpPlop(Cnt)) & " "
- Else
- End If
- Next Cnt
- Let UnEeks = Left(UnEeks, Len(UnEeks) - 1)
- Let strSptInDrpPlop() = Split(UnEeks, " ", -1, vbBinaryCompare)
- Dim Eye As Long, Jay As Long
- For Eye = 0 To UBound(strSptInDrpPlop()) - 1
- For Jay = Eye + 1 To UBound(strSptInDrpPlop())
- If IsNumeric(strSptInDrpPlop(Eye)) And IsNumeric(strSptInDrpPlop(Jay)) Then
- If CLng(strSptInDrpPlop(Eye)) > CLng(strSptInDrpPlop(Jay)) Then
- Dim Temp As String: Let Temp = strSptInDrpPlop(Jay): Let strSptInDrpPlop(Jay) = strSptInDrpPlop(Eye): Let strSptInDrpPlop(Eye) = Temp
- Else
- End If
- Else
- If strSptInDrpPlop(Eye) > strSptInDrpPlop(Jay) Then
- Let Temp = strSptInDrpPlop(Jay): Let strSptInDrpPlop(Jay) = strSptInDrpPlop(Eye): Let strSptInDrpPlop(Eye) = Temp
- Else
- End If
- End If
- Next Jay
- Next Eye
- With Worksheets("DataSaladinValagationLists")
- Let .Range("A" & Target.Row & "").Value = "-"
- Let .Cells.Item(Target.Row, 2).Resize(1, UBound(strSptInDrpPlop()) + 1).Value = strSptInDrpPlop()
- Let .Cells.Item(Target.Row, UBound(strSptInDrpPlop()) + 3).Value = "Blank"
- End With
- Target.Validation.Delete
- Target.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=DataSaladinValagationLists!A" & Target.Row & ":" & CLDoWhile(UBound(strSptInDrpPlop()) + 3) & "" & Target.Row & ""
- End Sub
- Function CLDoWhile(ByVal lclm As Long) As String
- Dim rest As Long
- Do
- Let CLDoWhile = Chr(65 + (((lclm - 1) Mod 26))) & CLDoWhile
- Let lclm = (lclm - (1)) \ 26
- Loop While lclm > 0
- End Function
- Public Sub Worksheet_Change(ByVal Target As Range)
- If IsArray(Target.Value) Then Exit Sub
- Rem 1 main worksheet data range info
- Dim CntItms As Long: Let CntItms = Me.Range("B" & Rows.Count & "").End(xlUp).Row
- If Application.Intersect(Target, Me.Range("A2:A" & CntItms & "")) Is Nothing Then Exit Sub
- Dim CntClms As Long: Let CntClms = Me.Cells.Item(1, Columns.Count).End(xlToLeft).Column
- If Target.Value = "Blank" Then Let Application.EnableEvents = False: Let Target.Value = "": Let Application.EnableEvents = True
- Rem 2 test data range reset
- If Target.Value = "-" Then
- Let Application.EnableEvents = False
- Let Me.Range("C1", Me.Cells.Item(CntItms, Worksheets("Sheet1 (2)").Cells.Item(1, Columns.Count).End(xlToLeft).Column)).Value = Worksheets("Sheet1 (2)").Range("C1", Worksheets("Sheet1 (2)").Cells.Item(CntItms, Worksheets("Sheet1 (2)").Cells.Item(1, Columns.Count).End(xlToLeft).Column)).Value
- Let Application.EnableEvents = True
- Rem 3 Get indices( column numbers) for required columns, and all row indicies
- Else
- Dim arrLine() As Variant: Let arrLine() = Me.Range(Me.Cells.Item(Target.Row, 1), Me.Cells.Item(Target.Row, CntClms)).Value
- Dim Cnt As Long
- Dim strClms As String: Let strClms = "1 2 "
- For Cnt = 3 To CntClms
- If CStr(arrLine(1, Cnt)) = CStr(Target.Value) Then
- Let strClms = strClms & Cnt & " "
- Else
- End If
- Next Cnt
- Let strClms = Left(strClms, Len(strClms) - 1)
- Dim clmsSpt() As String: Let clmsSpt() = Split(strClms, " ", -1, vbBinaryCompare)
- Dim Clms() As String: ReDim Clms(1 To UBound(clmsSpt()) + 1)
- For Cnt = 0 To UBound(clmsSpt())
- Let Clms(Cnt + 1) = clmsSpt(Cnt)
- Next Cnt
- Dim Rws() As Variant: Let Rws() = Evaluate("=Row(1:" & CntItms & ")")
- Rem 4 Output filtered columns
- Dim arrOut() As Variant: Let arrOut() = Application.Index(Cells, Rws(), Clms())
- Let Application.EnableEvents = False
- Me.Cells.ClearContents
- Let Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
- Let Application.EnableEvents = True
- End If
- End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement