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]

How the final result should be:

Code.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC
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		Week 2			2	08:00 TP	07:30:00	07:30:00		2	17:30 TP	09:00:00	08:00:00
3		John Fox		Week 1			2	16:00 TP	10:00:00	08:00:00		2	17:30 TP	10:00:00	08:00:00		Week 2			2	16:00 TP	10:00:00	08:00:00		2	17:30 TP	10:00:00	08:00:00
4		Matt Anderson		Week 1			2	16:00 TP	09:00:00	07:30:00		2	17:30 TP	09:45:00	07:15:00		Week 2			2	16:00 TP	09:00:00	07:30:00		2	17:30 TP	09:45:00	07:15:00
5
6
7
Main

 

[DanteAmor]

The 2nd occurrence of the same name should start on Column Q in this case

Are there always 2 names?

 

[Remi909]

Are there always 2 names?

Not always 2 names. On similar sheets, There are more than 2

 

[DanteAmor]

Are always the columns to be copied are from D to P (13 columns)?

 

[Remi909]

Are always the columns to be copied are from D to P (13 columns)?

Yeah, D to P

 

[DanteAmor]

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

Sub copyrange()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim dic As Object
  Dim i As Long, col As Long, lr As Long
  Dim f As Range
  Dim v As Variant
  
  Application.ScreenUpdating = False
  
  Set sh1 = Sheets("Main")
  Set sh2 = Sheets("Results")
  Set dic = CreateObject("Scripting.Dictionary")
  dic.comparemode = vbTextCompare
  sh2.Rows("2:" & Rows.Count).ClearContents
  
  For i = 2 To sh1.Range("B" & Rows.Count).End(3).Row
    v = sh1.Range("B" & i).Value
    If Not dic.exists(v) Then
      dic(v) = -1
    Else
      dic(v) = dic(v) + 1
    End If
    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 * dic(v))
      sh1.Range("D" & i & ":P" & i).Copy sh2.Cells(f.Row, col)
    End If
  Next
  
  Application.ScreenUpdating = True
End Sub

 

[Remi909]

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

Sub copyrange()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim dic As Object
  Dim i As Long, col As Long, lr As Long
  Dim f As Range
  Dim v As Variant
 
  Application.ScreenUpdating = False
 
  Set sh1 = Sheets("Main")
  Set sh2 = Sheets("Results")
  Set dic = CreateObject("Scripting.Dictionary")
  dic.comparemode = vbTextCompare
  sh2.Rows("2:" & Rows.Count).ClearContents
 
  For i = 2 To sh1.Range("B" & Rows.Count).End(3).Row
    v = sh1.Range("B" & i).Value
    If Not dic.exists(v) Then
      dic(v) = -1
    Else
      dic(v) = dic(v) + 1
    End If
    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 * dic(v))
      sh1.Range("D" & i & ":P" & i).Copy sh2.Cells(f.Row, col)
    End If
  Next
 
  Application.ScreenUpdating = True
End Sub

Hello Dante,

Thank you for responding. I've ran that code and I get an error code: "Run-time '429': ActiveX component can't create object"

The line stops at Set dic = CreateObject("Scripting.Dictionary")

Any assistance in debugging?

Thank you in advance

 

[DanteAmor]

Again I put the dictionary statement and it doesn't work in your version. I must create another macro, when I have it, then I post it.

 

[DanteAmor]

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