remove specific character and exclude the other for multiple sheets

[Ali M]

hello
I have this data for multiple sheets .

c.xlsm
	A	B	C	D	E
1	ITEM	CODE	SSTR	QTY	BALANCE
2	1		VBA 123T123 215.5*S12.5BOTTOLE 1L PR123 NRIT214 TR	23	12
3	2		SLFR-101 FOOD-12 PR1011 NRIT2K CHI	5	1
4	3		SLFR FOOOD-1 RF100 NBGFR IND	10	2
5	4		DM/10 120***225l20 FSLUNCH PR121 BMTTR	11	12
dd

what I want it remove specific characters and exclude the first,second and last item from deletion
should be like this in column B

c.xlsm
	A	B	C	D	E
1	ITEM	CODE	SSTR	QTY	BALANCE
2	1	VBA 123T123 TR	215.5*S12.5BOTTOLE 1L PR123 NRIT214	23	12
3	2	SLFR-101 FOOD-12 CHI	PR1011 NRIT2K	5	1
4	3	SLFR FOOOD-1 IND	RF100 NBGFR	10	2
5	4	DM/10 120***225l20 BMTTR	FSLUNCH PR121	11	12
dd

if it's possible by macro will be great because the data could be 2000 rows for each sheet
thanks

 

[Rick Rothstein]

See if this macro does what you want...

Sub SeparateData()
  Dim R As Long, LastRow As Long, Txt As String, Arr As Variant
  LastRow = Cells(Rows.Count, "C").End(xlUp).Row
  For R = 2 To LastRow
    Txt = Cells(R, "C").Value
    Arr = Split(Txt)
    Cells(R, "B").Value = Join(Application.Index(Arr, 1, Split("1 2 " & 1 + UBound(Arr))))
    Cells(R, "C").Value = Mid(Left(Txt, InStrRev(Txt, " ") - 1), InStr(InStr(Txt, " ") + 1, Txt, " ") + 1)
  Next
End Sub

 

[Ali M]

great !
two thing please when you have time .could modiyfy code,please? . first about last items . also I want two last items instead of one last item
like this as in first item

VBA 123T123 NRIT214 TR​

second how could implement the code for multiple sheets (sheet1,sheet2,sheet3)?
thanks

 

[Ali M]

another option?

 

[bebo021999]

2 inputboxes will pop up to let user choose.

Option Explicit
Sub test()
Dim lr&, FItem, LItem, i&, j&, rng, s, arr()
FItem = InputBox(" number of first items?")
LItem = InputBox(" number of last items?")
If Not IsNumeric(FItem) Or Not IsNumeric(LItem) Then
    MsgBox "Invalid value"
    Exit Sub
End If
lr = Cells(Rows.Count, "C").End(xlUp).Row
rng = Range("A2:E" & lr).Value
ReDim arr(1 To lr - 1, 1 To 2)
For i = 1 To lr - 1
    s = Split(rng(i, 3))
    For j = 0 To UBound(s)
        If j + 1 <= FItem Or j + 1 >= UBound(s) - LItem + 2 Then
            arr(i, 1) = arr(i, 1) & " " & s(j)
        Else
            arr(i, 2) = arr(i, 2) & " " & s(j)
        End If
    Next
Next
Range("B2").Resize(UBound(arr), 2).Value = arr
End Sub

In case do not want inputboxes, but harcode the number to, i.e, first =2, last = 2:
Replace this:

FItem = InputBox(" number of first items?")
LItem = InputBox(" number of last items?")

by this:

FItem = 2
LItem = 2

 

[Ali M]

@bebo021999 you're awsome!

two choices are great especially the first. I want implementing your code in multiple sheets as I mentioned in OP & post#3 . can I copy the items instead of move from column C to column B? I mean to should not delete the items from column C should keep the orginal data in column C .

thanks

 

[bebo021999]

OK. Try:

Option Explicit
Sub test()
Dim lr&, FItem, LItem, i&, j&, rng, s, arr(), ws As Worksheet
FItem = InputBox(" number of first items?")
LItem = InputBox(" number of last items?")
    If Not IsNumeric(FItem) Or Not IsNumeric(LItem) Then
        MsgBox "Invalid value"
        Exit Sub
    End If
For Each ws In Sheets
    lr = ws.Cells(Rows.Count, "C").End(xlUp).Row
    rng = ws.Range("C2:C" & lr).Value
    ReDim arr(1 To lr - 1, 1 To 1)
    For i = 1 To lr - 1
        s = Split(rng(i, 1))
        For j = 0 To UBound(s)
            If j + 1 <= FItem Or j + 1 >= UBound(s) - LItem + 2 Then
                arr(i, 1) = arr(i, 1) & " " & s(j)
            End If
        Next
    Next
    ws.Range("B2").Resize(UBound(arr), 1).Value = arr
Next
End Sub

 

[Ali M]

@bebo021999 much appreciated for following my thread and gave me the solution