Increasing the Column Input Range on VBA Macro where Data is to be transposed into rows

[Nicw24]

I am a bit green when it comes to VBA, however, I have a piece of working code where the first two columns on a spreadsheet (Column A: Firm Name and Column B: Name of Item) are being used to transpose the name of items for each firm into a single row. I would like to increase the selected data to three columns, which would include the firm's email address. Please could someone advise on the change needed to the VBA code below.

Current Code Example:

Firm Name	Name of Item
Firm A	Item A
Firm B	Item B
Firm B	Item C

Current Results:

Firm Name	Name of Item 1	Name of Item 2
Firm A	Item A

Firm B

Item B

Item C

New input table:

Firm Name	email address	Name of Item
Firm A	Fred@FirmA.com	Item A
Firm B	Wilma@FirmB.com	Item B

Firm B

Wilma@FirmB.com

Item C

Firm Name	email address	Name of Item 1	Name of Item 2
Firm A	Fred@FirmA.com	Item A

Firm B

Wilma@FirmB.com

Item B

Item C

VBA Code:

ub TransposeRows()
'Define Variables
Dim RowsNumber As Long
Dim p As Long
Dim xColCr As String
Dim xColumn As New Collection
Dim InputRng As Range
Dim OutputRng As Range
Dim RngText As String
Dim CountRow As Long
Dim xRowRg As Range
On Error Resume Next
'Set values and Input Box fot Input Range
RngText = ActiveWindow.RangeSelection.Address
Set InputRng = Application.InputBox("Select Your Input Range for 2 columns:", "ExcelDemy", RngText, , , , , 8)
Set InputRng = Application.Intersect(InputRng, InputRng.Worksheet.UsedRange)
'Apply Condition to count only 2 columns and to show msg box for alerting to select only two columns
If InputRng Is Nothing Then Exit Sub
If (InputRng.Columns.Count <> 2) Or _
(InputRng.Areas.Count > 1) Then
MsgBox "The specified range is only area for 2 columns ", , "ExcelDemy"
Exit Sub
End If
'Set values and Input Box fot Input Range
Set OutputRng = Application.InputBox("Select Your Output Range (one cell):", "ExcelDemy", RngText, , , , , 8)
If OutputRng Is Nothing Then Exit Sub
Set OutputRng = OutputRng.Range(1)
'Count Rows
RowsNumber = InputRng.Rows.Count
'Apply For loop
For p = 2 To RowsNumber
xColumn.Add InputRng.Cells(p, 1).Value, InputRng.Cells(p, 1).Value
Next
Application.ScreenUpdating = False
For p = 1 To xColumn.Count
xColCr = xColumn.Item(p)
OutputRng.Offset(p, 0) = xColCr
InputRng.AutoFilter Field:=1, Criteria1:=xColCr
Set xRowRg = InputRng.Range("B2:B" & RowsNumber).SpecialCells(xlCellTypeVisible)
If xRowRg.Count > CountRow Then CountRow = xRowRg.Count
'Copy and paste with transpose
InputRng.Range("B2:B" & RowsNumber).SpecialCells(xlCellTypeVisible).Copy
OutputRng.Offset(p, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
Next
OutputRng = InputRng.Cells(1, 1)
OutputRng.Offset(0, 1).Resize(1, CountRow) = InputRng.Cells(1, 2)
InputRng.Rows(1).Copy
OutputRng.Resize(1, CountRow + 1).PasteSpecial Paste:=xlPasteFormats
InputRng.AutoFilter
Application.ScreenUpdating = True
End Sub

Thanks for everyone's anticipated help.