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>
 

Some videos you may like

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,095
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
12,095
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
12,095
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
12,095
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,101,786
Messages
5,482,923
Members
407,368
Latest member
FunkyFriedChicken

This Week's Hot Topics

  • Finding issue in If elseif else with For each Loop
    Finding issue in If elseif else with For each Loop I have tried this below code but i'm getting in Y column filled with W005. Colud you please...
  • MsgBox Error
    Hi Guys, I have the below error show up when i try and run my macro in File1 but works fine if i copy and paste the same code into file2. [ATTACH...
  • CELL FORMAT - IF CONDITION
    My Cell Format is [B]""0.00" Cr". [/B]But in the cell, it is showing 123.00 for editing. (123 is entry figure). (Data imported from other...
  • Show numbers nearly the same
    Is this possible. I have a number that can change very time eg 0.00001234 Then I have a lot of numbers 0.0000001, 0.0000002, 0.00000004...
  • Please i need your help to create formula
    I need a formula in cell B8 to do this >>if b1=1 then multiply ( cell b8) by 10% ,if b1=2 multiply by 20%,if=3 multiply by 30%. Thank you in...
  • Got error while adding column and filter
    Got error while adding column and filter In column Z has some like "Success" and "Error". I want to add column in AA if the Z cell value is...
Top