如何複製多次重複單元格？

Question

我有一個表

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 
    ................... 

我需要把這個表格轉換爲

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 
    .................. 

我怎樣才能做到這一點使用VBA？

這裏是我試過到目前爲止

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

看評論後，這個會移動的N組數據到一個單一的一組列。這假設每行都包含一個Name/ID組合的數據，如你的例子。

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

看看這對你的作品，它遍歷各行各找工資/ EDUC /相關工作經驗的條目，直到不能找到另一個，移動每一個的底部與相應的名稱/ ID和清理一切都很好，你。

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