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>
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
7,784
Office Version
2007
Platform
Windows
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
 

yazzy10

New Member
Joined
Nov 11, 2019
Messages
9
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
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
7,784
Office Version
2007
Platform
Windows
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.
 

yazzy10

New Member
Joined
Nov 11, 2019
Messages
9
What does the error message say?



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
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
7,784
Office Version
2007
Platform
Windows
Did you modify some of the macro?

What version of excel and office do you have?
 
Last edited:

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
7,784
Office Version
2007
Platform
Windows
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.
 

Forum statistics

Threads
1,077,907
Messages
5,337,102
Members
399,125
Latest member
manibiotech

Some videos you may like

This Week's Hot Topics

Top