Macro to copy values across rows and transposing them and add the user id

yazzy10

New Member
Joined
Nov 11, 2019
Messages
9
Hi,


I wonder if someone can help me with this problem with amacro.

I have a table of data that appears below(input data) whichhas usernames down a few rows and one or more accounts across 70 columns.

On a regular basis, I would need to able to copy all theaccount numbers that are present in each cell and copy it into a column (see output data)

Also I would need to add the username in a second column(see output data).

Given that this task could involve hundreds of usernames oraccount numbers, I would need a macro to cut down the time to process thisfile.

I would really appreciate the help!

Many thanks,





Input Data

UsernameLaat Login Date/Time
No. Registered PremisesAccount No 1Account No 2Account No 3Account No 4Account No 5Account No 6Account No 7Account No 8Account No 9Account No 10Account No 11Account No 12Account No 13Account No 14Account No 15Account No 16Account No 17Account No 18Account No 19Account No 20Account No 21Account No 22Account No 23Account No 24Account No 25Account No 26Account No 27Account No 28Account No 29Account No 30Account No 31Account No 32Account No 33Account No 34Account No 35Account No 36Account No 37Account No 38Account No 39Account No 40Account No 41Account No 42Account No 43Account No 44Account No 45Account No 46Account No 47Account No 48Account No 49Account No 50Account No 51Account No 52Account No 53Account No 54Account No 55Account No 56Account No 57Account No 58Account No 59Account No 60Account No 61Account No 62Account No 63Account No 64Account No 65Account No 66Account No 67Account No 68Account No 69
user1@btmail.com31/07/2014 11:55 77777777
user2@hotmaiz.com05/08/2014 07:57 8888888863047667
user3@infinity.co.uk07/08/2014 10:12 3333333363577302
user4@gmain.co.in03/09/2014 14:22 102322841078539711151490114405261160743511607883 12149027 1288521312910505 1318059813187596134177301442467614564348146470861468423&148035021551641&15612261156125481584795815947863161051481644010716756737169079311713601617318737176328121772301&17766300179403581837318618463559190400731906658019214967198198361994932220153068201562062047409921029187305596983072489431810617319650523310049736517050405388974920494&50189801505722976305901063072394 6363248171491640 913473169151330291519584
user5@topaz..uk08/09/2014 12:13 11750080 12637498 12924166 7149215491207976
user6@yahool.co.uk12/09/2014 11:55 11640187 6309404&6313536963530898
<colgroup><col width="138" style="width: 104pt; mso-width-source: userset; mso-width-alt: 5046;"> <col width="139" style="width: 104pt; mso-width-source: userset; mso-width-alt: 5083;"> <col width="162" style="width: 122pt; mso-width-source: userset; mso-width-alt: 5924;"> <col width="88" style="width: 66pt; mso-width-source: userset; mso-width-alt: 3218;" span="9"> <col width="96" style="width: 72pt; mso-width-source: userset; mso-width-alt: 3510;" span="60"> <tbody> </tbody>


Output Data



AccountUsername
77777777user1@btmail.com
88888888user2@hotmaiz.com
63047667user2@hotmaiz.com
<colgroup><col width="64" style="width: 48pt;"> <col width="136" style="width: 102pt; mso-width-source: userset; mso-width-alt: 4973;"> <tbody> </tbody>
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Try this, change "Input" and "Output" for the name of your sheets

Code:
Sub copy_values_across()
  Dim sh1 As Worksheet, sh2 As Worksheet, a() As Variant, b() As Variant
  Dim lr As Long, lc As Long, i As Long, j As Long, n As Long
  Set sh1 = Sheets("[COLOR=#0000ff]Input[/COLOR]")
  Set sh2 = Sheets("[COLOR=#0000ff]Output[/COLOR]")
  sh2.Rows("2:" & Rows.Count).ClearContents
  lr = sh1.Range("A" & Rows.Count).End(xlUp).Row
  lc = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
  a = sh1.Range("A2", sh1.Cells(lr, lc)).Value
  ReDim b(1 To (UBound(a) * lc), 1 To 2)
  n = 1
  For i = 1 To UBound(a, 1)
    For j = 4 To lc
      If a(i, j) <> "" Then
        b(n, 1) = a(i, 1)
        b(n, 2) = a(i, j)
        n = n + 1
      End If
    Next
  Next
  sh2.Range("A2").Resize(UBound(b), 2).Value = b()
End Sub
 
Upvote 0
Hi Dante,

Thank you forposing you reply.

Although im having a runtime error 1004 on the last line of code:

sh2.Range("A2").Resize(UBound(b), 2).Value = b()

Would you know what is the cause of this?

Again many thanks or helping out
 
Upvote 0
What does the error message say?
Do you have formulas on the sheet?
The formulas have error?
Do you have merged cells?
Is the output sheet protected?
Do You have empty rows?

The macro assumes that you have headings in row 1 and that your data begins in row 2 in column A.
Maybe you can share more details of how your information is on the sheets.
 
Upvote 0
What does the error message say?

9PlI0ELams 4AOCLYMYFIDkELgDJIXABSA6BC0ByCFwAkkPgApAcAheA5BC4ACSHwAUgOQQuAMkhcAFIDoELQHIIXACSQ ACkBwCF4DkELgAJIfABSA5BC4AySFwAUiMyP95itAhXw6bqAAAAABJRU5ErkJggg==


Do you have formulas on the sheet? No
The formulas have error? No
Do you have merged cells?No
Is the output sheet protected?No
Do You have empty rows?No

The macro assumes that you have headings in row 1 and that your data begins in row 2 in column A.-The layout is exactly the same in the example above so data begins in row 2 in column A.

Many thanks
 
Upvote 0
Did you modify some of the macro?

What version of excel and office do you have?
 
Last edited:
Upvote 0
Try this

Code:
Sub copy_values_across()
  Dim sh1 As Worksheet, sh2 As Worksheet, a() As Variant, b() As Variant
  Dim lr As Long, lc As Long, i As Long, j As Long, n As Long
  Set sh1 = Sheets("Input")
  Set sh2 = Sheets("Output")
  sh2.Rows("2:" & Rows.Count).ClearContents
  lr = sh1.Range("A" & Rows.Count).End(xlUp).Row
  lc = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
  a = sh1.Range("A2", sh1.Cells(lr, lc)).Value
  ReDim b(1 To (UBound(a) * lc), 1 To 2)
  n = 1
  For i = 1 To UBound(a, 1)
    For j = 4 To lc
      If a(i, j) <> "" Then
        b(n, 1) = a(i, 1)
        b(n, 2) = a(i, j)
        n = n + 1
      End If
    Next
  Next
  
  For i = 1 To UBound(b)
    sh2.Range("A" & i).Value = b(i, 1)
    sh2.Range("B" & i).Value = b(i, 2)
  Next
End Sub

Some instructions are different for version 365.
If the above does not work, we will have to wait for someone else who can help, my version is Excel 2007.
 
Upvote 0

Forum statistics

Threads
1,213,560
Messages
6,114,306
Members
448,564
Latest member
ED38

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