add message & disable the code based on condition

[abdo meghari]

hi

I have this code splits column into multiple columns , but if the spaces among the items are differnt I mean it's not one space among the items it will show error subscript out of range .

so what I want if the space is not equal one space among the items should show message " there are differnt spaces should correct them " and highlighted the cells by red into column D which doesn't contain one space among the items and disabling the macro and doesn't split the column until correct the space for the items are exsted into cells for column D .
note: the macro wll split column into four columns based on containing the cells in column D contains four items.

Sub Sample()
    Dim ws As Worksheet
    Dim LastRow As Long, i As Long
    Dim tmpArray() As String

    '~~> This is the relevant sheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    With ws
        LastRow = .Range("D" & .Rows.Count).End(xlUp).Row

        For i = 2 To LastRow
            If InStr(1, .Range("D" & i).Value, " ") Then
                tmpArray = Split(.Range("D" & i).Value, " ")
                .Range("E" & i).Value = tmpArray(0)
                .Range("F" & i).Value = tmpArray(1)
                .Range("G" & i).Value = tmpArray(2)
                .Range("H" & i).Value = tmpArray(3)
              
                
            End If
        Next i
    End With
End Sub

Bridgestone SPLIT).xlsm
	D
1	MRGED
2	BS 1200R20 TCF G580 JAP
3	BS 1200R20 TC G580 THI
4	BS 1200R24 G582 JAP
5	BS 13R22.5 R187 JAP
6	BS 1400R20 T VSJ JAP
7	BS 155R12C R623 IND
8	BS 165R13C R624 IND
9	BS 175/70R13 EP150 IND
10	BS 175/70R14 EP150 THI
11	BS 1800R25 VKT** JAP
12	BS 185/65R14 EP150 IND
13	BS 185/65R14 TEC THI
14	BS 185/65R15 T005 IND
15	BS 185/65R15 T01 JAP
16	BS 185/70R13 EP150 IND
17	BS 195/60R15 EP150 THA
18	BS 195/65R15 EP15 JAP
19	BS 195/65R15 EP150 THI
20	BS 195/70R15C R623 JAP
21	BS 195R14C 613 JAP
22	BS 195R15C R623 THI
23	BS 205/60R16 T001 JAP
24	BS 205/65R15 EP150 IND
25	BS 205/70R15C R623 THI
26	BS 205R16C D840 THI
27	BS 215/50R17 EP300 THI
28	BS 215/55R16 EP300 IND
29	BS 215/55R17 AR20 IND
30	BS 215/55R17 GR90 IND
31	BS 215/55R17 MY-02 THI
32	BS 215/60R16 EP300 THI
33	BS 215/60R16 T005A THI
34	BS 215/70R15C R623 THI
35	BS 225/55R16 EP300 IND
36	BS 225/60R16 EP300 IND
37	BS 225/60R16 T001 JAP
38	BS 225/70R15C R623 JAP
39	BS 225/70R16 D687 JAP
40	BS 225/70R16 H005 THI
41	BS 225/70R17 D697 THI
42	BS 235/55R17 T005 THA
43	BS 235/55R17 ER300 JAP
44	BS 235/55R18 E031 JAP
45	BS 235/60R16 T01 JAP
46	BS 245/40ZR20 S001 JAP
47	BS 245/45R17 T05A JAP
48	BS 245/45R18 EP300 THI
49	BS 245/45R19 T005 JAP
50	BS 245/70R17 684A JAP
51	BS 245/75R17 693A JAP
52	BS 255/70R15C D840 THI
53	BS 265/50R20 DHPA JAP
54	BS 265/60R18 D840 JAP
55	BS 265/65R17 D840 JAP
56	BS 265/70R16 D840 THI
57	BS 265/70R18 D684 JAP
58	BS 275/40R18 S007 JAP
59	BS 275/40R20 Dsport JAP
60	BS 275/45R19 AL01 JAP
61	BS 275/55R17 Dsport JAP
62	BS 275/55R20 AL01 JAP
63	BS 275/65R18 AL01 JAP
64	BS 275/70R16 D694 JAP
65	BS 285/60R18 DHPS JAP
66	BS 285/65R17 R683 JAP
67	BS 315/80R22.5 R152 JAP
68	BS 315/80R22.5 R184 JAP
69	BS 315/80R22.5 R184 THI
70	BS 315/80R22.5-18PR G580 JAP
71	BS 315/80R22.5-18PR G582 THI
72	BS 325/95R24 G582 JAP
73	BS 385/65R22.5 R164 JAP
74	BS 385/65R22.5 R164 THA
75	BS 425/65R22.5 R164 JAP
76	BS 445/65R22.5 R164 JAP
77	BS 650R16 R230 JAP
78	BS 700R16 R230 JAP
79	BS 750R16 R230 JAP
80	BS 750R16 VSJ JAP
81	BS LT285/75R16 AT001 JAP
82	DT 315/80R22.5 T DS50 THI
83	DT 385/65R22.5 DT40 THI
84	FS 205/65R15 TZ700 JAP
85	FS 215/55R17 TZ700 JAP
ITEM

any suggestion expert to complete this code ?

 

[RobVos]

Will there always be only 4?

 

[mumps]

Try:

Sub Sample()
    Dim ws As Worksheet, tmpArray() As String, LastRow As Long, i As Long, RowCount As Long
    Set ws = ThisWorkbook.Sheets("Sheet1")
    With ws
        LastRow = .Range("D" & .Rows.Count).End(xlUp).Row
        For i = 2 To LastRow
            tmpArray = Split(.Range("D" & i).Value, " ")
            If UBound(tmpArray) > 3 Then
                Range("D" & i).Interior.ColorIndex = 3
            End If
        Next i
        .Range("D1").CurrentRegion.AutoFilter Field:=1, Criteria1:=RGB(255, 0, 0), Operator:=xlFilterCellColor
        RowCount = .[subtotal(103,D:D)] - 1
        .Range("D1").AutoFilter
        If RowCount > 1 Then
            MsgBox ("Please correct the different spaces in the colored cells.")
            Exit Sub
        Else
            For i = 2 To LastRow
                tmpArray = Split(.Range("D" & i).Value, " ")
                .Range("E" & i).Value = tmpArray(0)
                .Range("F" & i).Value = tmpArray(1)
                .Range("G" & i).Value = tmpArray(2)
                .Range("H" & i).Value = tmpArray(3)
            Next i
        End If
    End With
End Sub

 

[RobVos]

If there is always only four, you could use the Trim function to remove any extra spaces to correct extra spaces first - then check to ensure there are four elements.

Sub Sample()
    Dim ws As Worksheet
    Dim LastRow As Long, i As Long
    Dim tmpArray() As String
    Dim BadFormat As Integer
    '~~> This is the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
BadFormat = 0
With ws
        lastRow = .Range("D" & .Rows.Count).End(xlUp).Row
        For i = 2 To lastRow
            'If InStr(1, .Range("D" & i).Value, " ") Then ' I remarked this, as I was not sure what the purpose was
            .Range("D" & i).Value = WorksheetFunction.Trim(Range("D" & i)) ' this will take out extra spaces
                tmparray = Split(.Range("D" & i).Value, " ")
                If UBound(tmparray) - LBound(tmparray) = 3 Then 'there must be four elements in the array
                  .Range("E" & i).Value = tmparray(0)
                  .Range("F" & i).Value = tmparray(1)
                  .Range("G" & i).Value = tmparray(2)
                  .Range("H" & i).Value = tmparray(3)
                  .Range("D" & i).Interior.ColorIndex = 0
                Else
                    .Range("D" & i).Interior.Color = vbRed
                    BadFormat = 1
                End If
            'End If ' this was from the IF statement I commented out above.
        Next i
End With
If BadFormat = 1 Then
    MsgBox "See highlighted rows which are not properly spaced."
End If
End Sub

 

[abdo meghari]

@mumps it shows error subscript ou of range in this line

.Range("F" & i).Value = tmpArray(1)

 

[steve the fish]

Something to consider if those are genuine spaces

With Sheets("Sheet1")
    lr = .Range("D" & .Rows.Count).End(xlUp).Row
    arr = .Range("D2:D" & lr)
    For i = LBound(arr) To UBound(arr)
        arr1 = Split(arr(i, 1), " ")
        counter = 0
        For j = LBound(arr1) To UBound(arr1)
            If Len(arr1(j)) > 0 Then
                .Cells(i + 1, counter + 5) = arr1(j)
                counter = counter + 1
            End If
        Next
    Next
End With

 

[mumps]

How many items does the cell D & i have?

 

[abdo meghari]

@RobVos thanks , but it just show the message without highlight any cell and when I correct the space, then the message still show . it shouldn't if the whole cells in column D contain one space among the items and should work the macro by split into four columns ..

 

[abdo meghari]

@mumps sorry ! this is my mistake . some cells shows five I corrected , but it just highlight cells without shows the message .

 

[RobVos]

The code I posted will take out any extra spaces (auto-correct) in D and then split it into the next four columns. If it is unable to do that because there are not only 4 elements, it does not split D and it should turn the applicable cell in D red. Correct the red cells and run again.

It will only display the message if it found a cell that would not split into four elements.