Columns to Rows based on email address

**hamcam** · 11-03-2021, 05:50 PM

I am so very stuck.

I have a list of 100s if not 1000s of file upload instances in a spreadsheet. Each Time an upload is made it is noted as text information in a column (to corresponding folder). Each email address uploads up to 12 files. I want to join the separate each with a single upload, to be one row with all 12 (or however many they have done)

WORST explanation ever... I know. I've had zero luck finding any help.

I've attached a workbook. The top is a small example of what i have and the bottom is what i am trying to get to though use of a VBA i think?

Thanks in advance folks!!

H

**Estevaoba** · 11-03-2021, 07:49 PM

Welcome to the forum.

I did it in row 42 down.

This array formula in A42 (confirm with Ctrl+Shift+Enter) and copy down to return unique values:

Formula:

=IFERROR(INDEX($A$3:$A$30,MATCH(1,(COUNTIF(A$41:A41,$A$3:$A$30)=0)*($A$3:$A$30<>""),0)),"")

And this formula in B42, copied across and down:

Formula:

=IFERROR(IF(INDEX($B$3:$M$30,AGGREGATE(15,6,(($A$3:$A$30=$A42)/($A$3:$A$30=$A42)*ROW($A$3:$A$30)-ROW($A$3)+1),COUNTIF($A42:A42,"<> ")),COLUMNS($A$1:A$1))=""," ",INDEX($B$3:$M$30,AGGREGATE(15,6,(($A$3:$A$30=$A42)/($A$3:$A$30=$A42)*ROW($A$3:$A$30)-ROW($A$3)+1),COUNTIF($A42:A42,"<> ")),COLUMNS($A$1:A$1)))," ")

Good luck!

**JohnTopley** · 11-04-2021, 07:21 AM

VBA:

Sub emails()

Dim inarr() As Variant
Dim outarr() As Variant

Dim n As Long
Dim r As Long
Dim c As Long
Dim lastrow As Long
Dim lastcol As Long

Dim outRng As Range

Dim ws1 As Worksheet
Dim ws2 As Worksheet

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

ws1.Activate

With ws1

    lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
    lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
    
    inarr = .Range(.Cells(2, 1), .Cells(lastrow, lastcol))
    
    n = 1
    ReDim outarr(1 To 500, 1 To lastcol)
    Email = inarr(1, 1)
    outarr(n, 1) = Email
    
    For r = 1 To UBound(inarr, 1)
       
        If inarr(r, 1) = Email Then
            For c = 2 To UBound(inarr, 2)
                If inarr(r, c) <> "" Then
                    outarr(n, c) = inarr(r, c)
                    Exit For
                End If
            Next c
        Else
            n = n + 1
            Email = inarr(r, 1)
            outarr(n, 1) = Email
            r = r - 1
        End If
        
    Next r

End With

With ws2
     Set outRng = .Range("A2").Resize(n, lastcol)
End With

outRng = outarr

ws2.Activate

'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True


End Sub

Input on Sheet1, output Sheet2