Macro to copy rows

S

sohelsa9

New Member
Joined
Oct 20, 2016
Messages
4
I need macro to cleanse Users column in following table.

My requirement is to split users column and extract user names between single quote ' and then create new record by copying those users in Owner column with DateTime and FileName as same.

There may or may not be users in in Users column
DateTime
FileName
Owner
Users
9/21/2015 1:36:55 PM
Test1
wrig
;1000000000;'cwatters';'kzal';20602;1500000057;'mhoy';'wrig';'spwi';'gcho';
9/21/2015 1:40:52 PM
Test2
kcuu
;1000000000;20602;1500000001;
9/21/2015 1:43:24 PM
Test3
dmvv
;1000000000;20602;'imjf';'nvey';'lhex';'cqws';1500000001;

<tbody>
</tbody>

Result should look like

DateTime
FileName
Owner
9/21/2015 1:36:55 PM
Test1
wrig
9/21/2015 1:36:55 PM
Test1
cwatters
9/21/2015 1:36:55 PM
Test1
kzal
9/21/2015 1:36:55 PM
Test1
mhoy
9/21/2015 1:36:55 PM
Test1
wrig
9/21/2015 1:36:55 PM
Test1
spwi
9/21/2015 1:36:55 PM
Test1
gcho
9/21/2015 1:40:52 PM
Test2
kcuu

<tbody>
</tbody>

I am able to use split the column into different columns and extract only user names which are present within single quote using but couldn't able to satisfy my complete requirement.

Appreciate your help.

Thanks,
 

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
Sort by date Sort by votes
sohelsa9,

Welcome to the MrExcel forum.

Here is a macro solution for you to consider.

You can change the raw data worksheet name in the macro.

Sample raw data:


Excel 2007
ABCD
1DateTimeFileNameOwnerUsers
29/21/2015 1:36:55 PMTest1wrig;1000000000;'cwatters';'kzal';20602;1500000057;'mhoy';'wrig';'spwi';'gcho';
39/21/2015 1:40:52 PMTest2kcuu;1000000000;20602;1500000001;
49/21/2015 1:43:24 PMTest3dmvv;1000000000;20602;'imjf';'nvey';'lhex';'cqws';1500000001
5
6
7
8
9
10
11
12
13
14
15
Sheet1


And, after the macro:


Excel 2007
ABCD
1DateTimeFileNameOwnerUsers
29/21/2015 1:36:55 PMTest1wrig;1000000000;'cwatters';'kzal';20602;1500000057;'mhoy';'wrig';'spwi';'gcho';
39/21/2015 1:36:55 PMTest1cwatters
49/21/2015 1:36:55 PMTest1kzal
59/21/2015 1:36:55 PMTest1mhoy
69/21/2015 1:36:55 PMTest1wrig
79/21/2015 1:36:55 PMTest1spwi
89/21/2015 1:36:55 PMTest1gcho
99/21/2015 1:40:52 PMTest2kcuu;1000000000;20602;1500000001;
109/21/2015 1:43:24 PMTest3dmvv;1000000000;20602;'imjf';'nvey';'lhex';'cqws';1500000001
119/21/2015 1:43:24 PMTest3imjf
129/21/2015 1:43:24 PMTest3nvey
139/21/2015 1:43:24 PMTest3lhex
149/21/2015 1:43:24 PMTest3cqws
15
Sheet1


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Code: 
Sub ExtractUsers()
' hiker95, 10/22/2016, ME971635
Dim lr As Long, r As Long, s, i As Long, n As Long, o() As Variant
Application.ScreenUpdating = False
With Sheets("Sheet1")   '<-- you can change the sheet name here
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  For r = lr To 2 Step -1
    If InStr(.Cells(r, 4), ";") Then
      s = Split(.Cells(r, 4), ";")
      n = 0
      For i = LBound(s) To UBound(s)
        If InStr(s(i), "'") Then
          n = n + 1
          ReDim Preserve o(1 To n)
          o(n) = Mid(s(i), 2, Len(s(i)) - 2)
        End If
      Next i
      If n > 0 Then
        .Rows(r + 1).Resize(n).Insert
        .Range("A" & r + 1).Resize(n, 2).Value = .Range("A" & r & ":B" & r).Value
        .Range("C" & r + 1).Resize(n).Value = Application.Transpose(o)
        Erase o
      End If
    End If
  Next r
  .Columns("A:C").AutoFit
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ExtractUsers macro.
 
Upvote 0
sohelsa9,

If you want the results to look like the following screenshot, then try the next macro, ExtractUsers_V2.


Excel 2007
ABCD
1DateTimeFileNameOwnerUsers
29/21/2015 1:36:55 PMTest1wrig
39/21/2015 1:36:55 PMTest1cwatters
49/21/2015 1:36:55 PMTest1kzal
59/21/2015 1:36:55 PMTest1mhoy
69/21/2015 1:36:55 PMTest1wrig
79/21/2015 1:36:55 PMTest1spwi
89/21/2015 1:36:55 PMTest1gcho
99/21/2015 1:40:52 PMTest2kcuu
109/21/2015 1:43:24 PMTest3dmvv
119/21/2015 1:43:24 PMTest3imjf
129/21/2015 1:43:24 PMTest3nvey
139/21/2015 1:43:24 PMTest3lhex
149/21/2015 1:43:24 PMTest3cqws
15
Sheet1




Code: 
Sub ExtractUsers_V2()
' hiker95, 10/22/2016, ME971635
Dim lr As Long, r As Long, s, i As Long, n As Long, o() As Variant
Application.ScreenUpdating = False
With Sheets("Sheet1")   '<-- you can change the sheet name here
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  For r = lr To 2 Step -1
    If InStr(.Cells(r, 4), ";") Then
      s = Split(.Cells(r, 4), ";")
      n = 0
      For i = LBound(s) To UBound(s)
        If InStr(s(i), "'") Then
          n = n + 1
          ReDim Preserve o(1 To n)
          o(n) = Mid(s(i), 2, Len(s(i)) - 2)
        End If
      Next i
      If n > 0 Then
        .Rows(r + 1).Resize(n).Insert
        .Range("A" & r + 1).Resize(n, 2).Value = .Range("A" & r & ":B" & r).Value
        .Range("C" & r + 1).Resize(n).Value = Application.Transpose(o)
        Erase o
      End If
    End If
  Next r
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  .Range("D2:D" & lr).ClearContents
  .Columns("A:D").AutoFit
End With
Application.ScreenUpdating = True
End Sub
 
Upvote 0
hiker95 said:
sohelsa9,

If you want the results to look like the following screenshot, then try the next macro, ExtractUsers_V2.

Excel 2007
ABCD
1DateTimeFileNameOwnerUsers
29/21/2015 1:36:55 PMTest1wrig
39/21/2015 1:36:55 PMTest1cwatters
49/21/2015 1:36:55 PMTest1kzal
59/21/2015 1:36:55 PMTest1mhoy
69/21/2015 1:36:55 PMTest1wrig
79/21/2015 1:36:55 PMTest1spwi
89/21/2015 1:36:55 PMTest1gcho
99/21/2015 1:40:52 PMTest2kcuu
109/21/2015 1:43:24 PMTest3dmvv
119/21/2015 1:43:24 PMTest3imjf
129/21/2015 1:43:24 PMTest3nvey
139/21/2015 1:43:24 PMTest3lhex
149/21/2015 1:43:24 PMTest3cqws
15

<tbody>
</tbody>
Sheet1​





Code: 
Sub ExtractUsers_V2()
' hiker95, 10/22/2016, ME971635
Dim lr As Long, r As Long, s, i As Long, n As Long, o() As Variant
Application.ScreenUpdating = False
With Sheets("Sheet1")   '<-- you can change the sheet name here
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  For r = lr To 2 Step -1
    If InStr(.Cells(r, 4), ";") Then
      s = Split(.Cells(r, 4), ";")
      n = 0
      For i = LBound(s) To UBound(s)
        If InStr(s(i), "'") Then
          n = n + 1
          ReDim Preserve o(1 To n)
          o(n) = Mid(s(i), 2, Len(s(i)) - 2)
        End If
      Next i
      If n > 0 Then
        .Rows(r + 1).Resize(n).Insert
        .Range("A" & r + 1).Resize(n, 2).Value = .Range("A" & r & ":B" & r).Value
        .Range("C" & r + 1).Resize(n).Value = Application.Transpose(o)
        Erase o
      End If
    End If
  Next r
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  .Range("D2:D" & lr).ClearContents
  .Columns("A:D").AutoFit
End With
Application.ScreenUpdating = True
End Sub
Click to expand...

Thanks a lot, it worked like a charm
 
Upvote 0
hiker95 said:
sohelsa9,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.
Click to expand...

Is there a way there can be another column added which should display whether the row was copied or original as below?
1DateTimeFileNameOwnerResult
29/21/2015 1:36:55 PMTest1wrigOriginal
39/21/2015 1:36:55 PMTest1cwattersCopied
49/21/2015 1:36:55 PMTest1kzalCopied
59/21/2015 1:36:55 PMTest1mhoyCopied
69/21/2015 1:36:55 PMTest1wrigCopied
79/21/2015 1:36:55 PMTest1spwiCopied
89/21/2015 1:36:55 PMTest1gchoCopied
99/21/2015 1:40:52 PMTest2kcuuOriginal
109/21/2015 1:43:24 PMTest3dmvvOriginal
119/21/2015 1:43:24 PMTest3imjfCopied
129/21/2015 1:43:24 PMTest3nveyCopied
139/21/2015 1:43:24 PMTest3lhexCopied
149/21/2015 1:43:24 PMTest3cqws

<tbody>
</tbody>
 
Upvote 0
Is there a way there can be another column added which should display whether the row was copied or original as below?
Click to expand...

sohelsa9,

Column D, Users, after the macro, will have a new title Result, with Original, or, Copied?
 
Upvote 0
sohelsa9,

Here is an new macro based on your reply #6.

You can change the raw data worksheet name in the macro.

Sample raw data:


Excel 2007
ABCD
1DateTimeFileNameOwnerUsers
29/21/2015 1:36:55 PMTest1wrig;1000000000;'cwatters';'kzal';20602;1500000057;'mhoy';'wrig';'spwi';'gcho';
39/21/2015 1:40:52 PMTest2kcuu;1000000000;20602;1500000001;
49/21/2015 1:43:24 PMTest3dmvv;1000000000;20602;'imjf';'nvey';'lhex';'cqws';1500000001
5
6
7
8
9
10
11
12
13
14
15
Sheet1


And, after the new macro:


Excel 2007
ABCD
1DateTimeFileNameOwnerResult
29/21/2015 1:36:55 PMTest1wrigOriginal
39/21/2015 1:36:55 PMTest1cwattersCopied
49/21/2015 1:36:55 PMTest1kzalCopied
59/21/2015 1:36:55 PMTest1mhoyCopied
69/21/2015 1:36:55 PMTest1wrigCopied
79/21/2015 1:36:55 PMTest1spwiCopied
89/21/2015 1:36:55 PMTest1gchoCopied
99/21/2015 1:40:52 PMTest2kcuuOriginal
109/21/2015 1:43:24 PMTest3dmvvOriginal
119/21/2015 1:43:24 PMTest3imjfCopied
129/21/2015 1:43:24 PMTest3nveyCopied
139/21/2015 1:43:24 PMTest3lhexCopied
149/21/2015 1:43:24 PMTest3cqwsCopied
15
Sheet1


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Code: 
Sub ExtractUsers_V3()
' hiker95, 10/24/2016, ME971635
Dim lr As Long, r As Long, s, i As Long, n As Long, o() As Variant
Application.ScreenUpdating = False
With Sheets("Sheet1")   '<-- you can change the sheet name here
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  For r = lr To 2 Step -1
    If InStr(.Cells(r, 4), ";") Then
      s = Split(.Cells(r, 4), ";")
      n = 0
      For i = LBound(s) To UBound(s)
        If InStr(s(i), "'") Then
          n = n + 1
          ReDim Preserve o(1 To n)
          o(n) = Mid(s(i), 2, Len(s(i)) - 2)
        End If
      Next i
      If n = 0 Then
        With .Range("D" & r)
          .Value = "Original"
          .Font.Bold = True
        End With
      End If
      If n > 0 Then
        .Rows(r + 1).Resize(n).Insert
        .Range("A" & r + 1).Resize(n, 2).Value = .Range("A" & r & ":B" & r).Value
        .Range("C" & r + 1).Resize(n).Value = Application.Transpose(o)
        With .Range("D" & r)
          .Value = "Original"
          .Font.Bold = True
        End With
        With .Range("D" & r + 1).Resize(n)
          .Value = "Copied"
          .Font.Bold = True
        End With
        Erase o
      End If
    End If
  Next r
  With .Range("D1")
    .Value = "Result"
    .Font.Bold = True
  End With
  .Columns("A:D").AutoFit
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ExtractUsers_V3 macro.
 
Upvote 0
sohelsa9,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
Filter large amount of data by multiple constraints
Replies
7
Views
208
Peter_SSs
Peter_SSs
willow1985
  • Solved
VBA copy set amount of rows into forms until end of data set
2
Replies
15
Views
291
willow1985
willow1985
H
  • Solved
Delete all rows including cells in column "A" that are identical to the values in cells "D1", "E1","F1" and "A6".
2
Replies
10
Views
283
Peter_SSs
Peter_SSs
S
  • Solved
VBA code for userform , to add data to specific cells based on combolistbox selection
Replies
6
Views
642
sloany101
S
D
  • Solved
Macro Transport Data
2
Replies
11
Views
573
decent_boy
D

Forum statistics

Threads
1,215,507
Messages
6,125,212
Members
449,214
Latest member
mr_ordinaryboy

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