Copy Area To Rows Using VBA

[Remi909]

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 Sub

 

[DanteAmor]

Try this:

Sub CopyData()
  Dim wsStart As Worksheet, wsTrans As Worksheet
  Dim i As Long, j As Long, k As Long, lr As Long, y As Long, n As Long
  Dim a As Variant, b As Variant
  Dim dic As Object
  
  Set wsStart = ActiveSheet
  Set dic = CreateObject("Scripting.Dictionary")
  dic.comparemode = vbTextCompare
  
  lr = wsStart.Range("A" & Rows.Count).End(3).Row
  n = Evaluate("=MAX(COUNTIF(A1:A" & lr & ",A1:A" & lr & "))")
  a = wsStart.Range("A1:C" & lr).Value
  ReDim b(1 To UBound(a, 1), 1 To (n * 2) + 1)
  
  For i = 1 To UBound(a, 1)
    If Not dic.exists(a(i, 1)) Then
      y = y + 1
      dic(a(i, 1)) = y & "|" & 2
      b(y, 1) = a(i, 1)
    End If
    j = Split(dic(a(i, 1)), "|")(0)
    k = Split(dic(a(i, 1)), "|")(1)
    b(j, k) = a(i, 2)
    b(j, k + 1) = a(i, 3)
    dic(a(i, 1)) = j & "|" & k + 2
  Next
  
  Set wsTrans = Sheets.Add
  wsTrans.Range("A1").Resize(y, UBound(b, 2)).Value = b
End Sub

 

[Remi909]

Try this:

Sub CopyData()
  Dim wsStart As Worksheet, wsTrans As Worksheet
  Dim i As Long, j As Long, k As Long, lr As Long, y As Long, n As Long
  Dim a As Variant, b As Variant
  Dim dic As Object
 
  Set wsStart = ActiveSheet
  Set dic = CreateObject("Scripting.Dictionary")
  dic.comparemode = vbTextCompare
 
  lr = wsStart.Range("A" & Rows.Count).End(3).Row
  n = Evaluate("=MAX(COUNTIF(A1:A" & lr & ",A1:A" & lr & "))")
  a = wsStart.Range("A1:C" & lr).Value
  ReDim b(1 To UBound(a, 1), 1 To (n * 2) + 1)
 
  For i = 1 To UBound(a, 1)
    If Not dic.exists(a(i, 1)) Then
      y = y + 1
      dic(a(i, 1)) = y & "|" & 2
      b(y, 1) = a(i, 1)
    End If
    j = Split(dic(a(i, 1)), "|")(0)
    k = Split(dic(a(i, 1)), "|")(1)
    b(j, k) = a(i, 2)
    b(j, k + 1) = a(i, 3)
    dic(a(i, 1)) = j & "|" & k + 2
  Next
 
  Set wsTrans = Sheets.Add
  wsTrans.Range("A1").Resize(y, UBound(b, 2)).Value = b
End Sub

Hello,

Thanks for getting back to me. Ive ran that code and I get an error code stating "Run-time '429': ActiveX component can't create object" and stops at Set dic = CreateObject("Scripting.Dictionary").

Do you mind assisting in the debugging?

Thanks

 

[DanteAmor]

Are you on the windows version?

 

[DanteAmor]

Try this option:

Sub CopyData_2()
  Dim wsStart As Worksheet, wsTrans As Worksheet
  Dim i As Long, j As Long
  Dim f As Range
  
  Set wsStart = ActiveSheet
  Set wsTrans = Sheets.Add
  
  For i = 1 To wsStart.Range("A" & Rows.Count).End(3).Row
    Set f = wsTrans.Range("A:A").Find(wsStart.Range("A" & i).Value, , xlValues, xlWhole, , , False)
    If f Is Nothing Then
      j = j + 1
      wsTrans.Range("A" & j).Resize(1, 3).Value = wsStart.Range("A" & i).Resize(1, 3).Value
    Else
      wsTrans.Cells(f.Row, Columns.Count).End(1)(1, 2).Resize(1, 2).Value = wsStart.Range("B" & i).Resize(1, 2).Value
    End If
  Next
End Sub

 

[Remi909]

Sub CopyData_2() Dim wsStart As Worksheet, wsTrans As Worksheet Dim i As Long, j As Long Dim f As Range Set wsStart = ActiveSheet Set wsTrans = Sheets.Add For i = 1 To wsStart.Range("A" & Rows.Count).End(3).Row Set f = wsTrans.Range("A:A").Find(wsStart.Range("A" & i).Value, , xlValues, xlWhole, , , False) If f Is Nothing Then j = j + 1 wsTrans.Range("A" & j).Resize(1, 3).Value = wsStart.Range("A" & i).Resize(1, 3).Value Else wsTrans.Cells(f.Row, Columns.Count).End(1)(1, 2).Resize(1, 2).Value = wsStart.Range("B" & i).Resize(1, 2).Value End If Next End Sub

Thank you! Worked like a charm.

Much appreciated

 

[DanteAmor]

In glad to help you. Thanks for the feedback.

 

[Remi909]

As slightly new to VBA, I was wondering if you could break down each line of code and what it does just for a better understanding from my end?

Thanks in advance

 

[DanteAmor]

I was wondering if you could break down each line of code

Sub CopyData_2()
  Dim wsStart As Worksheet, wsTrans As Worksheet
  Dim i As Long, j As Long
  Dim f As Range
  
  Set wsStart = ActiveSheet
  Set wsTrans = Sheets.Add
  
  'Cycle from 1 to the last cell with data from the start sheet of column A. ...
  For i = 1 To wsStart.Range("A" & Rows.Count).End(3).Row
  
    'finds each A value on the Start sheet with the find method in column A:A on the Trans sheet
    Set f = wsTrans.Range("A:A").Find(wsStart.Range("A" & i).Value, , xlValues, xlWhole, , , False)
    
    If f Is Nothing Then
    
    'If object f is empty then add a record on the trans sheet and put the values of cells a, b and c
      j = j + 1
      wsTrans.Range("A" & j).Resize(1, 3).Value = wsStart.Range("A" & i).Resize(1, 3).Value
    Else
    
    'If you found the data, then in the same row, at the end of the data, add the data from cells b and c
      wsTrans.Cells(f.Row, Columns.Count).End(1)(1, 2).Resize(1, 2).Value = wsStart.Range("B" & i).Resize(1, 2).Value
    End If
  Next
End Sub

 

[Peter_SSs]

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: Copy Area To Rows Using VBA - OzGrid Free Excel/VBA Help Forum
If you have posted the question at more places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.