'VBA call macro to split cells when cell changes
Trying to make a macro that automatically calls another macro to extract parts of the entered string and insert into two other cells. The splitting macro works when called on a cell manually but cannot get it to trigger automatically.
Sub splitEnvServ()
'
' Macro3 Macro
'
'
Selection.TextToColumns destination:=ActiveCell.Offset(, 2), DataType:=xlDelimited, \_
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, \_
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar \_
\:="/", FieldInfo:=Array(Array(1, 9), Array(2, 9), Array(3, 9), Array(4, 9), Array(5, \_
9), Array(6, 9), Array(7, 9), Array(8, 9), Array(9, 9), Array(10, 9), Array(11, 9), Array(12 \_
, 9), Array(13, 9), Array(14, 1), Array(15, 9), Array(16, 1), Array(17, 9), Array(18, 9)), \_
TrailingMinusNumbers:=True
End Sub
'
' Part that won't trigger
'
'
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Target.Worksheet.Range("B13")) Is Nothing Then splitEnvServ
End Sub
Solution 1:[1]
A Worksheet Change: Split Cell to Row
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ClearError
Const cAddress As String = "B13"
Dim iCell As Range: Set iCell = Intersect(Range(cAddress), Target)
If iCell Is Nothing Then Exit Sub
Application.EnableEvents = False
SplitEnvServ iCell
SafeExit:
On Error Resume Next
If Not Application.EnableEvents Then Application.EnableEvents = True
On Error GoTo 0
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub
Sub SplitEnvServ(ByVal Cell As Range)
Const Delimiter As String = "/"
Const ColumnOffset As Long = 1
With Cell.Offset(, ColumnOffset)
Dim lCell As Range: Set lCell = .Resize(, Columns.Count - .Column + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If Not lCell Is Nothing Then
.Resize(, lCell.Column - .Column + 1).ClearContents
End If
End With
Dim Sentence As String: Sentence = CStr(Cell.Value)
If Len(Sentence) = 0 Then Exit Sub
Dim Words() As String: Words = Split(Sentence, Delimiter)
Cell.Offset(, ColumnOffset).Resize(, UBound(Words) + 1).Value = Words
End Sub
Solution 2:[2]
In your sub you missing the End if. Try:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Target.Worksheet.Range("B13")) Is Nothing Then
splitEnvServ
End If
End Sub
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
| Solution | Source |
|---|---|
| Solution 1 | |
| Solution 2 | Chux |
