Copy Range To Rows Using VBA Code

[Remi909]

I have the following worksheet that I need to transpose according to the number of occurrence in a column (same name etc) within a specific column (B1) and copy the entire column and its row content on to one new row below. The 2nd occurrence of the same name should start on Column Q in this case:

Code.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R
1	Site	Name	Start Weekday	Week 1 Name	Week 1 Min Paid	Week 1 Max Paid	Week 1 1 DayOff	Week 1 1 Shift	Week 1 1 Start	Week 1 1 Paid	Week 1 1 Activity 1	Week 1 2 DayOff	Week 1 2 Shift	Week 1 2 Start	Week 1 2 Paid	Week 1 2 Activity 1
2	Green Site	Adam Smith		Week 1			2	08:00 TP	07:30:00	07:30:00		2	17:30 TP	09:00:00	08:00:00
3		Adam Smith		Week 2			2	08:00 TP	07:30:00	07:30:00		2	17:30 TP	09:00:00	08:00:00
4		John Fox		Week 1			2	16:00 TP	10:00:00	08:00:00		2	17:30 TP	10:00:00	08:00:00
5		John Fox		Week 2			2	16:00 TP	10:00:00	08:00:00		2	17:30 TP	10:00:00	08:00:00
6		Matt Anderson		Week 1			2	16:00 TP	09:00:00	07:30:00		2	17:30 TP	09:45:00	07:15:00
7		Matt Anderson		Week 2			2	16:00 TP	09:00:00	07:30:00		2	17:30 TP	09:45:00	07:15:00
8
9
10
11
Main

Thanks in advance!

 

[Remi909]

Create a new sheet and name it as "Results". Run the following macro, the records will be on the "Results" sheet.

Try this:

Sub copyrange()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, col As Long, lr As Long, n As Long
  Dim f As Range
  Dim v As Variant
 
  Application.ScreenUpdating = False
 
  Set sh1 = Sheets("Main")
  Set sh2 = Sheets("Results")
  sh2.Rows("2:" & Rows.Count).ClearContents
 
  For i = 2 To sh1.Range("B" & Rows.Count).End(3).Row
    v = sh1.Range("B" & i).Value
    n = WorksheetFunction.CountIf(sh1.Range("B1:B" & i - 1), v) - 1
    Set f = sh2.Range("B:B").Find(v, , xlValues, xlWhole, , , False)
    If f Is Nothing Then
      lr = sh2.Range("B" & Rows.Count).End(3).Row + 1
      sh1.Range("A" & i & ":P" & i).Copy sh2.Range("A" & lr)
    Else
      col = Columns("Q").Column + (13 * n)
      sh1.Range("D" & i & ":P" & i).Copy sh2.Cells(f.Row, col)
    End If
  Next
 
  Application.ScreenUpdating = True
End Sub

Hi Dante,

That worked.
Could break down each line of code and what it does just for a better understanding from my end?

Thanks in advance

 

[DanteAmor]

Could break down each line of code and what it does just for a better understanding from my end?

Sub copyrange()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, col As Long, lr As Long, n As Long
  Dim f As Range
  Dim v As Variant
  
  Application.ScreenUpdating = False
  
  Set sh1 = Sheets("Main")
  Set sh2 = Sheets("Results")
  sh2.Rows("2:" & Rows.Count).ClearContents
  
  For i = 2 To sh1.Range("B" & Rows.Count).End(3).Row
    'Puts the data in the variable v
    v = sh1.Range("B" & i).Value
    'Count the occurrences of v in column B, it is to know in which column you should put the next block.
    n = WorksheetFunction.CountIf(sh1.Range("B1:B" & i - 1), v) - 1
    'Look for v in the results sheet, in column B.
    Set f = sh2.Range("B:B").Find(v, , xlValues, xlWhole, , , False)
    If f Is Nothing Then
      'If the method does not find it, then it adds a record.
      lr = sh2.Range("B" & Rows.Count).End(3).Row + 1
      sh1.Range("A" & i & ":P" & i).Copy sh2.Range("A" & lr)
    Else
      'If it exists, then add the columns
      col = Columns("Q").Column + (13 * n)
      sh1.Range("D" & i & ":P" & i).Copy sh2.Cells(f.Row, col)
    End If
  Next
  
  Application.ScreenUpdating = True
End Sub

 

[Remi909]

Sub copyrange()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, col As Long, lr As Long, n As Long
  Dim f As Range
  Dim v As Variant
 
  Application.ScreenUpdating = False
 
  Set sh1 = Sheets("Main")
  Set sh2 = Sheets("Results")
  sh2.Rows("2:" & Rows.Count).ClearContents
 
  For i = 2 To sh1.Range("B" & Rows.Count).End(3).Row
    'Puts the data in the variable v
    v = sh1.Range("B" & i).Value
    'Count the occurrences of v in column B, it is to know in which column you should put the next block.
    n = WorksheetFunction.CountIf(sh1.Range("B1:B" & i - 1), v) - 1
    'Look for v in the results sheet, in column B.
    Set f = sh2.Range("B:B").Find(v, , xlValues, xlWhole, , , False)
    If f Is Nothing Then
      'If the method does not find it, then it adds a record.
      lr = sh2.Range("B" & Rows.Count).End(3).Row + 1
      sh1.Range("A" & i & ":P" & i).Copy sh2.Range("A" & lr)
    Else
      'If it exists, then add the columns
      col = Columns("Q").Column + (13 * n)
      sh1.Range("D" & i & ":P" & i).Copy sh2.Cells(f.Row, col)
    End If
  Next
 
  Application.ScreenUpdating = True
End Sub

Thank you!!

 

[DanteAmor]

Im glad to help you, thanks for the feedback.