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>
 
Sounds like you have too much data. Add this message box as shown, what does it say
Code:
  Next
 [COLOR=#ff0000] MsgBox UBound(b)[/COLOR]
  sh2.Range("A2").Resize(UBound(b), 2).Value = b()
 
Upvote 0

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Hi Dante

Thank again,this macro does work (even a funny way!) it gives me an error "Method 'Range' of object'_Worksheet'failed but in the Output sheet I have all the info I need :)

Not sure if it need a tweak but it is working so thank you!
 
Upvote 0
Hi Dante

Thank again,this macro does work (even a funny way!) it gives me an error "Method 'Range' of object'_Worksheet'failed but in the Output sheet I have all the info I need :)

Not sure if it need a tweak but it is working so thank you!

Hi @yazzy10, I am not sure what the message may mean.But if your data is good and complete, then it was a pleasure to help you.:cool:


Thanks for the feedback.
 
Upvote 0
Thanks fr your input- adding the ms box gives 127944-what does this means?
It means that there are 127,944 rows of data to be output to sheet, which is fine.
One possible reason for the error you originally got, was if you were trying to output more than 1,048,576 rows.
 
Upvote 0
The following could give us a more accurate result of the final number of rows:

Try this please.
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
[COLOR=#0000ff]  n = WorksheetFunction.CountA(sh1.Range("D2", sh1.Cells(lr, lc)))[/COLOR]
  ReDim b(1 To [COLOR=#0000ff]n[/COLOR], 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()
  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
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,255
Members
448,556
Latest member
peterhess2002

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