if there is repetition, copy and move VBA

S

spasmex97

New Member
Joined
Jul 8, 2024
Messages
19
Office Version
  1. 2019
Platform
  1. Windows
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.stp14078000.stp47652452.stp47652453.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
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
Sort by date Sort by votes
Why does this need to be VBA? Will a formula suffice? How about
Excel Formula: 
=TRANSPOSE(TEXTAFTER(A2:A4,"\"))

spasmex97 said:
but data set could be way longer and repetitions can various from 2 to 10 or more
Click to expand...
What does this mean exactly? Can you show an example of what this would look like?
 
Upvote 0
See if something like this is any use. I have assumed data in column A and nothing in columns to the right of that.

VBA 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
  End With
End Sub

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

spasmex97.xlsm
ABCDEFGH
1
247652499_ASM\14078000.stp47652499_ASM\14078000.stp14078000.stp47652452.stp47652453.stp
347652499_ASM\47652452.stpabc\k1k1k2k3k4k5
447652499_ASM\47652453.stpdef\7676
5abc\k1xyz\bb88bb88bb89
6abc\k2
7abc\k3
8abc\k4
9abc\k5
10def\76
11xyz\bb88
12xyz\bb89
Sheet1
 
Upvote 0
severynm said:
Why does this need to be VBA? Will a formula suffice? How about
Excel Formula: 
=TRANSPOSE(TEXTAFTER(A2:A4,"\"))


What does this mean exactly? Can you show an example of what this would look like?
Click to expand...
because in the dataset there are more than 14000 lines
dosya yolu olusturma makro.xlsm
ABC
2.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652433\47652433.stp
3.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652437\47652437.stp
4.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652441\47652441.stp
5.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652446\47652446.stp
6.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652447\47652447.stp
7.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652499_ASM\14078000.stp
8.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652499_ASM\47652452.stp
9.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652499_ASM\47652453.stp
10.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652499_ASM\47652499_ASM.stp
11.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652499_ASM\47868753.stp
12.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652510_ASM\14098810.stp
13.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652510_ASM\47652508.stp
14.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652510_ASM\47652509.stp
15.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652510_ASM\47652510_ASM.stp
16.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652512_ASM\14098710.stp
17.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652512_ASM\47652512_ASM.stp
18.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652512_ASM\47652513.stp
19.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652518_ASM\14098810.stp
20.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652518_ASM\47652518_ASM.stp
21.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652518_ASM\47652520.stp
22.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652521_ASMaçılmadı\14098710.stp
23.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652521_ASMaçılmadı\47652521_ASM.stp
24.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652521_ASMaçılmadı\47652522.stp
25.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47652553\47652553.stp
26.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47723128\47723128.stp
27.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47769526_ASM\14098710.stp
28.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47769526_ASM\47769526_ASM.stp
29.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47769526_ASM\47769528.stp
30.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47769529_ASM\14098710.stp
31.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47769529_ASM\47769529_ASM.stp
32.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47769529_ASM\47769530.stp
33.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47814231_ASM\14096900.stp
34.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47814231_ASM\47652454.stp
35.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES47814231_ASM\47814231_ASM.stp
36.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES84396454\84396454.stp
37.stpC:\Users\Hakan\Desktop\TTF_DATA_TEK_RES84396456\84396456.stp
TTF_DATA_TEK_RES
 
Upvote 0
Peter_SSs said:
See if something like this is any use. I have assumed data in column A and nothing in columns to the right of that.

VBA 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
  End With
End Sub

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

spasmex97.xlsm
ABCDEFGH
1
247652499_ASM\14078000.stp47652499_ASM\14078000.stp14078000.stp47652452.stp47652453.stp
347652499_ASM\47652452.stpabc\k1k1k2k3k4k5
447652499_ASM\47652453.stpdef\7676
5abc\k1xyz\bb88bb88bb89
6abc\k2
7abc\k3
8abc\k4
9abc\k5
10def\76
11xyz\bb88
12xyz\bb89
Sheet1
Click to expand...
yes that would work, only needed to delete the rows on A:A which transpozed
 
Upvote 0
spasmex97 said:
only needed to delete the rows on A:A which transpozed
Click to expand...
Try (on a copy of your workbook) adding the red line of code.

Rich (BB 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
 
Upvote 0
Solution
Peter_SSs said:
Try (on a copy of your workbook) adding the red line of code.

Rich (BB 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
Click to expand...
that worked perfectly as i wanted, thank you, best regards
 
Upvote 0
You're welcome. Thanks for the confirmation. :)
 
Upvote 0
That error should be completely unrelated to your Excel version.
However, what line of the code causes the error?
 
Upvote 0
You must log in or register to reply here.

Similar threads

Rob_010101
  • Solved
VBA to turn a row into values only (based on list item)
Replies
3
Views
69
Peter_SSs
Peter_SSs
J
  • Question Question
Update Power Query through VBA
Replies
0
Views
122
johnny51981
J
Q
  • Question Question
Macro needed to insert 4 rows in table, copy data from above, copy data from another sheet and paste special (transpose values) to those new rows...re
Replies
1
Views
309
sijpie
sijpie
J
  • Question Question
Crazy Formula to VBA.
Replies
2
Views
211
jvoss
J
E
  • Question Question
Simple VBA to move down one cell, and insert
Replies
1
Views
271
Joe4
Joe4

Forum statistics

Threads
1,224,152
Messages
6,176,724
Members
452,740
Latest member
MrCY

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top