How to copy multiple times repeating cells? - excel

Question

I have a table
Name ID Salary Educ Exp Salary Educ Exp
Mike 1 100 5 12 200 12 23
Peter 2 200 6 12 300 3 32
Lily 3 150 3 13 200 5 2
...................
I need to transform this table into
Name ID Salary Educ Exp
Mike 1 100 5 12
Peter 2 200 6 12
Lily 3 150 3 13
Mike 1 200 12 23
Peter 2 300 3 32
Lily 3 200 5 2
..................
How can I do this using VBA ?
Here is what I tried so far
Sub test()
Dim rg1 As Range, rg2 As Range, rg3 As Range, shtDest As Worksheet
Dim lLoop As Long, lRowDest As Long
Set rg1 = Selection.Areas(1)
Set rg2 = Selection.Areas(2)
Set rg3 = Selection.Areas(3)
Set shtDest = Worksheets.Add
lRowDest = 1
For lLoop = 1 To rg1.Rows.Count
lRowDest = lRowDest + rg2.Rows.Count + rg3.Rows.Count
Next
End Sub

Answer 1

After looking at the comments, this will move N sets of data into a single set of columns. This assumes that each row contains data for one Name/ID combination, as in your example.
Sub moveData()
Dim x As Range
Dim data As Range
Dim i As Long
Dim origId As Range
Dim id As Range
Dim idColCount As Long
Dim setCount As Long
Dim setCol As Long
Dim headerRange As Range
Set headerRange = Range("1:1")
Set id = Range(Range("A2"), Range("B2").End(xlDown))
Set origId = id
idColCount = id.Columns.Count
setCount = Application.WorksheetFunction.CountIfs(headerRange, "salary")
setCol = 1
For i = 1 To setCount
With headerRange
Set x = .Find("Salary", .Cells(1, setCol))
Set data = x.Offset(1).Resize(x.End(xlDown).Row - x.Row, 3)
data.Copy
id.Cells(1, 1).Offset(id.rows.Count, idColCount).PasteSpecial xlPasteAll
origId.Copy
id.Cells(1, 1).Offset(id.rows.Count).PasteSpecial xlPasteAll
Set id = Range(id, id.End(xlDown))
End With
setCol = x.Column
Next i
setCol = 1
With headerRange
Set x = .Find("Salary", .Cells(1, setCol))
setCol = x.Column
Set x = .Find("Salary", .Cells(1, setCol))
End With
Range(x, x.End(xlToRight).End(xlDown)).Clear
End Sub

Answer 2

See if this works for you, it loops through each row finding each Salary/Educ/Exp entry until it doesn't find another, moving each one to the bottom with the corresponding Name/ID and cleans up everything nicely for you.
Private Sub SplitTable()
Dim rng As Range '' range we want to iterate through
Dim c As Range '' iterator object
Dim cc As Range '' check cell
Dim lc As Range '' last cell
Dim ws As Worksheet
Dim keepLooking As Boolean '' loop object
Dim firstTime As Boolean
Dim offset As Integer
Dim Name As String, ID As Integer, Salary As Integer, Educ As Integer, Exp As Integer
Set ws = ActiveSheet '' adjust this to the sheet you want or leave it as ActiveSheet
Set rng = ws.Range("A2", "A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
For Each c In rng
firstTime = True '' reset to true so we get an offset of five for the first entry
keepLooking = True
While keepLooking
If firstTime Then
Set cc = c.offset(, 5)
Else: Set cc = cc.offset(, 3)
End If
If cc <> "" Then '' if the salary has data in it, then grab what we expect to be Salaray/Educ/Exp
Name = c.Value
ID = c.offset(, 1).Value
Salary = cc.Value
Educ = cc.offset(, 1).Value
Exp = cc.offset(, 2).Value
'' Cleanup
cc.ClearContents
cc.offset(, 1).ClearContents
cc.offset(, 2).ClearContents
'' Move it to the bottom of columns A:E
Set lc = ws.Range("A" & ws.Rows.Count).End(xlUp).offset(1, 0)
lc.Value = Name
lc.offset(, 1).Value = ID
lc.offset(, 2).Value = Salary
lc.offset(, 3).Value = Educ
lc.offset(, 4).Value = Exp
Else: keepLooking = False
End If
firstTime = False '' set to false so we only get an offset of 3 from here on out
Wend
Next c
ws.Range("F1", ws.Range("A1").End(xlToRight)).ClearContents
End Sub