if there is repetition, copy and move VBA

[spasmex97]

I have a data set which is in Column A and something like this

47652499_ASM\14078000.stp

47652499_ASM\47652452.stp

47652499_ASM\47652453.stp

and i would like to move that part after "\" and want to see it like

47652499_ASM\14078000.stp

14078000.stp

47652452.stp

47652453.stp

but data set could be way longer and repetitions can various from 2 to 10 or more
i think it would like to hold the (i,j) value and then compare it with (i+1,j) and so on until there is no match then hold the new cell's value and repeat, but i have lack of excel skills so i am looking for your help guys, thank you in advance

 

[severynm]

Why does this need to be VBA? Will a formula suffice? How about

=TRANSPOSE(TEXTAFTER(A2:A4,"\"))

but data set could be way longer and repetitions can various from 2 to 10 or more

What does this mean exactly? Can you show an example of what this would look like?

 

[Peter_SSs]

See if something like this is any use. I have assumed data in column A and nothing in columns to the right of that.

Sub Rearrange()
  Dim a As Variant, b As Variant, Bits As Variant
  Dim i As Long, k As Long
  Dim CurrPref As String
  
  With Range("A2", Range("A" & Rows.Count).End(xlUp))
    a = .Value
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
      Bits = Split(a(i, 1), "\")
      If Bits(0) = CurrPref Then
        b(k, 1) = b(k, 1) & ";" & Bits(1)
      Else
        CurrPref = Bits(0)
        k = k + 1
        b(k, 1) = a(i, 1) & ";" & Bits(1)
      End If
    Next i
    With .Offset(, 1).Resize(k)
      .Value = b
      .TextToColumns DataType:=xlDelimited, Semicolon:=True, Comma:=False, Space:=False, Other:=False
      .CurrentRegion.Columns.AutoFit
    End With
  End With
End Sub

My sample data in column A and code results in columns B, C, D, ...

spasmex97.xlsm
	A	B	C	D	E	F	G	H
1
2	47652499_ASM\14078000.stp	47652499_ASM\14078000.stp	14078000.stp	47652452.stp	47652453.stp
3	47652499_ASM\47652452.stp	abc\k1	k1	k2	k3	k4	k5
4	47652499_ASM\47652453.stp	def\76	76
5	abc\k1	xyz\bb88	bb88	bb89
6	abc\k2
7	abc\k3
8	abc\k4
9	abc\k5
10	def\76
11	xyz\bb88
12	xyz\bb89
Sheet1

 

[spasmex97]

Why does this need to be VBA? Will a formula suffice? How about

=TRANSPOSE(TEXTAFTER(A2:A4,"\"))

What does this mean exactly? Can you show an example of what this would look like?

because in the dataset there are more than 14000 lines

dosya yolu olusturma makro.xlsm
	A	B	C
2	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652433\47652433.stp
3	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652437\47652437.stp
4	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652441\47652441.stp
5	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652446\47652446.stp
6	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652447\47652447.stp
7	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652499_ASM\14078000.stp
8	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652499_ASM\47652452.stp
9	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652499_ASM\47652453.stp
10	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652499_ASM\47652499_ASM.stp
11	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652499_ASM\47868753.stp
12	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652510_ASM\14098810.stp
13	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652510_ASM\47652508.stp
14	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652510_ASM\47652509.stp
15	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652510_ASM\47652510_ASM.stp
16	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652512_ASM\14098710.stp
17	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652512_ASM\47652512_ASM.stp
18	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652512_ASM\47652513.stp
19	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652518_ASM\14098810.stp
20	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652518_ASM\47652518_ASM.stp
21	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652518_ASM\47652520.stp
22	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652521_ASMaçılmadı\14098710.stp
23	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652521_ASMaçılmadı\47652521_ASM.stp
24	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652521_ASMaçılmadı\47652522.stp
25	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47652553\47652553.stp
26	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47723128\47723128.stp
27	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47769526_ASM\14098710.stp
28	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47769526_ASM\47769526_ASM.stp
29	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47769526_ASM\47769528.stp
30	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47769529_ASM\14098710.stp
31	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47769529_ASM\47769529_ASM.stp
32	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47769529_ASM\47769530.stp
33	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47814231_ASM\14096900.stp
34	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47814231_ASM\47652454.stp
35	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	47814231_ASM\47814231_ASM.stp
36	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	84396454\84396454.stp
37	.stp	C:\Users\Hakan\Desktop\TTF_DATA_TEK_RES	84396456\84396456.stp
TTF_DATA_TEK_RES

 

[spasmex97]

See if something like this is any use. I have assumed data in column A and nothing in columns to the right of that.

Sub Rearrange()
  Dim a As Variant, b As Variant, Bits As Variant
  Dim i As Long, k As Long
  Dim CurrPref As String
 
  With Range("A2", Range("A" & Rows.Count).End(xlUp))
    a = .Value
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
      Bits = Split(a(i, 1), "\")
      If Bits(0) = CurrPref Then
        b(k, 1) = b(k, 1) & ";" & Bits(1)
      Else
        CurrPref = Bits(0)
        k = k + 1
        b(k, 1) = a(i, 1) & ";" & Bits(1)
      End If
    Next i
    With .Offset(, 1).Resize(k)
      .Value = b
      .TextToColumns DataType:=xlDelimited, Semicolon:=True, Comma:=False, Space:=False, Other:=False
      .CurrentRegion.Columns.AutoFit
    End With
  End With
End Sub

My sample data in column A and code results in columns B, C, D, ...

spasmex97.xlsm
	A	B	C	D	E	F	G	H
1
2	47652499_ASM\14078000.stp	47652499_ASM\14078000.stp	14078000.stp	47652452.stp	47652453.stp
3	47652499_ASM\47652452.stp	abc\k1	k1	k2	k3	k4	k5
4	47652499_ASM\47652453.stp	def\76	76
5	abc\k1	xyz\bb88	bb88	bb89
6	abc\k2
7	abc\k3
8	abc\k4
9	abc\k5
10	def\76
11	xyz\bb88
12	xyz\bb89
Sheet1

yes that would work, only needed to delete the rows on A:A which transpozed

 

[Peter_SSs]

only needed to delete the rows on A:A which transpozed

Try (on a copy of your workbook) adding the red line of code.

Sub Rearrange()
  Dim a As Variant, b As Variant, Bits As Variant
  Dim i As Long, k As Long
  Dim CurrPref As String
  
  With Range("A2", Range("A" & Rows.Count).End(xlUp))
    a = .Value
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
      Bits = Split(a(i, 1), "\")
      If Bits(0) = CurrPref Then
        b(k, 1) = b(k, 1) & ";" & Bits(1)
      Else
        CurrPref = Bits(0)
        k = k + 1
        b(k, 1) = a(i, 1) & ";" & Bits(1)
      End If
    Next i
    With .Offset(, 1).Resize(k)
      .Value = b
      .TextToColumns DataType:=xlDelimited, Semicolon:=True, Comma:=False, Space:=False, Other:=False
      .CurrentRegion.Columns.AutoFit
    End With
    .EntireColumn.Delete
  End With
End Sub

 

[spasmex97]

Try (on a copy of your workbook) adding the red line of code.

Sub Rearrange()
  Dim a As Variant, b As Variant, Bits As Variant
  Dim i As Long, k As Long
  Dim CurrPref As String
 
  With Range("A2", Range("A" & Rows.Count).End(xlUp))
    a = .Value
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
      Bits = Split(a(i, 1), "\")
      If Bits(0) = CurrPref Then
        b(k, 1) = b(k, 1) & ";" & Bits(1)
      Else
        CurrPref = Bits(0)
        k = k + 1
        b(k, 1) = a(i, 1) & ";" & Bits(1)
      End If
    Next i
    With .Offset(, 1).Resize(k)
      .Value = b
      .TextToColumns DataType:=xlDelimited, Semicolon:=True, Comma:=False, Space:=False, Other:=False
      .CurrentRegion.Columns.AutoFit
    End With
    .EntireColumn.Delete
  End With
End Sub

that worked perfectly as i wanted, thank you, best regards

 

[Peter_SSs]

You're welcome. Thanks for the confirmation.

 

[spasmex97]

You're welcome. Thanks for the confirmation.

Sorry for bothering again but i changed my office version to 2019, and now i get " subscript out of range" error, why it occurs?

 

[Peter_SSs]

That error should be completely unrelated to your Excel version.
However, what line of the code causes the error?