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.
Thanks for your anticipated help.
Current Code Example:
Data table
| Firm Name | Name of Item |
| Firm A | Item A |
| Firm B | Item B |
| Firm B | Item C |
Macro Results
| Firm Name | Name of item 1 | Name of item 2 |
| Firm A | Item A | |
| Firm B | Item B | Item C |
Requested Code Example:
Data Table:
| Firm Name | email address | Name of Item |
| Firm A | [email protected] | Item A |
| Firm B | [email protected] | Item B |
| Firm B | [email protected] | Item C |
Expected Results
| Firm Name | email address | Name of item 1 | Name of item 2 |
| Firm A | [email protected] | Item A | |
| Firm B | [email protected] | Item B | tem C |
Code
Sub 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