Question

我有一个包含一组问题的数据集。但是，受访者的部分数据已被复制（4列）。这些需要根据它们的标题合并为4列（答案1，答案2，答案3，答案4）。

我试过这个：

Sub MoveLeft()
Dim r As Long, rws As Long

Application.ScreenUpdating = False
    With ActiveSheet.UsedRange
        rws = .Rows.Count
        r = 1
        On Error Resume Next
        Do
            .Rows(r).Resize(8000).SpecialCells(xlBlanks).Delete Shift:=xlToLeft
            r = r + 8000
        Loop While r <= rws
        On Error GoTo 0
    End With
    Application.ScreenUpdating = True
End Sub

但它没有保留我需要的空白

Answer 1

您无法以8000行为一组进行此操作。每行都需要单独完成。

Sub qwerty()
    Dim r As Long, pos As Long
    With Worksheets("sheet2")
        With Intersect(.Range("F:AC"), .UsedRange.Cells)
            For r = 2 To .Rows.Count
                .Cells(r, 1).Resize(1, 4).ClearContents
                pos = .Cells(r, 1).End(xlToRight).Column - .Cells(r, 1).Column
                If pos <= .Columns.Count Then
                    pos = Application.Floor(pos, 4) + 1
                    .Cells(r, 1).Resize(1, 4) = .Cells(r, pos).Resize(1, 4).Value2
                End If
            Next r
        End With
    End With
End Sub

VBA向左移动数据（每行需要移动4列，在需要保留的4列中可能有空白）

1 个答案: