将所有行转移到第一个共同行

Question

我有100K Excel文件，其中包含许多员工信息，我想将所有存在数据转移到该员工的第一行，下面的图片会比我的话更响亮，VBA代码可以这样做吗？或者excel中有一个我不知道的技巧

Answer 1

请尝试以下代码。

Sub Demo()
    Dim ws As Worksheet
    Dim cel As Range, rng As Range
    Dim lastRow As Long, lastCol As Long, i As Long
    Dim fOccur As Long, lOccur As Long, colIndex As Long
    Dim dict As Object, c1
    Application.ScreenUpdating = False

    Set ws = ThisWorkbook.Sheets("Sheet1")  'change Sheet1 to your data range
    Set dict = CreateObject("Scripting.Dictionary")

    With ws
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row with data in Column A
        lastCol = .Cells.Find(What:="*", _
                        After:=.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column        'last column with data in Sheet1

        Set rng = .Range("A1:A" & lastRow)              'set range in Column A
        c1 = .Range("A2:A" & lastRow)
        For i = 1 To UBound(c1, 1)                      'using dictionary to get uniques values from Column A
            dict(c1(i, 1)) = 1
        Next i

        colIndex = 16       'colIndex+1 is column number where data will be displayed from
        For Each k In dict.keys     'loopthrough all unique values in Column A
            fOccur = Application.WorksheetFunction.Match(k, rng, 0) 'get row no. of first occurrence
            lOccur = Application.WorksheetFunction.CountIf(rng, k)  'get row no. of last occurrence
            lOccur = lOccur + fOccur - 1

            'copy range from left to right
            .Range(.Cells(fOccur, 1 + colIndex), .Cells(lOccur, lastCol + colIndex)).Value = .Range(.Cells(fOccur, 1), .Cells(lOccur, lastCol)).Value
            'delete blanks in range at right
            .Range(.Cells(fOccur, 1 + colIndex), .Cells(lOccur, lastCol + colIndex)).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp 'delte blank rows
        Next k
    End With
    Application.ScreenUpdating = True
End Sub

Answer 2

尝试以下方法。您可以修改以下代码以匹配您想要移动范围的位置：

Dim oW As Worksheet: Set oW = ThisWorkbook.Worksheets("Sheet8")

With oW.UsedRange
    .Cut .Offset(0, .Columns.Count + 2)
End With