MODERATOR NOTICE: This topic has also been posted on other sites and may already have an answer elsewhere. Please take this into consideration when answering this question
crossposted: https://www.mrexcel.com/board/…o-rows-using-vba.1206336/
Hello fellow VBA users,
I have an issue and I'll really appreciate some help. I have this VBA code but I'll like it to count the number of occurrence (same name etc) within a specific column (A1) and copy the entire column and its row content on to one new row below.
The VBA code I have prompts the user to select the area that needs copying and I'll like to eliminate that.
I have added the VBA code below.
I have also attached a mock example of before and after results.
Thank you!
-------------------------------------------------------------------------------------------------------------------------------
Sub CopyAreasToRows()
Dim lRows As Long
Dim lCol As Long
Dim lColCount As Long
Dim rCol As Range
Dim lPasteRow As Long
Dim lLoopCount As Long
Dim rRange As Range
Dim rCell As Range
Dim wsStart As Worksheet
Dim wsTrans As Worksheet
Set rCol = Application.InputBox(Prompt:="Select columns", _
Title:="TRANSPOSE ROWS", Type:=8)
'Cancelled or non valid range
If rCol Is Nothing Then Exit Sub
'Set Worksheet variables
Set wsStart = ActiveSheet
Set wsTrans = Sheets.Add()
On Error Resume Next
Application.ScreenUpdating = False
lColCount = rCol.Columns.Count
lPasteRow = 1
Set rRange = rCol.Range(wsStart.Cells(1, 1), wsStart.Cells(wsStart.Rows.Count, 1).End(xlUp))
For Each rCell In rRange
If rCell <> "" Then
lLoopCount = rCell.Row
With wsStart
.Range(.Cells(lLoopCount, 1), .Cells(lLoopCount, lColCount)).Copy
End With
wsTrans.Cells(lPasteRow, wsTrans.Columns.Count).End(xlToLeft)(1, 2).PasteSpecial
Application.CutCopyMode = False
Else
lPasteRow = lPasteRow + 1
End If
Next rCell
With wsTrans
.Columns.AutoFit
.Columns(1).Delete
End With
On Error GoTo 0
Application.ScreenUpdating = True
End SubBefore:
After:
