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组数据移动到一组列中。这假定每行包含一个名称/ 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

看看这是否适合你，它会遍历每一行找到每个Salary / Educ / Exp条目，直到它找不到另一个，用相应的名称/ 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

如何复制多次重复细胞？

2 个答案: