CODEWITHSUNDEEP
excelvba
Andrei Vasilev
Andrei Vasilev

Reputation: 607

How to copy multiple times repeating cells?

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

Upvotes: 3

Views: 754

Answers (2)

bamblack
bamblack

Reputation: 3779

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

Upvotes: 4

Will Ediger
Will Ediger

Reputation: 893

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

Upvotes: 4

Related Questions