Question

我有一个包含几千行的电子表格，我需要重新格式化以允许丢失数据。我使用的是列A到M，其中列A，C，E，H，K和M包含编号数据，其余是不重要的数字。如果a = c = e = h = k = m，则我需要我的脚本逐行检查。如果他们确实匹配，那么移动到下一行（数字增加1（第1行应该在1，c，e，h，k，m，第2行应该有2＆＃39; s等）））。如果数字发生变化，我需要移动发生变化的行的其余部分，以便a，c，e，h，k和m中的数字重新对齐。

Sub ()
    Dim lastRow As Integer
    Dim curRow As Integer
    Dim sel As Range
    Dim elt As Range
    Dim mybool As Boolean
    Dim Mini As Integer
    Dim col As Integer

    'Worksheet name and cells range
    With Worksheets("Sheet2").Range("A1:M")

        curRow = 1
        lastRow = .Rows.Count
        col = .Column
        mybool = True
        Mini = 0

        Application.ScreenUpdating = False

        Do While curRow < lastRow

            'Worksheet name...
            Set sel = Intersect(.Rows(curRow), Union(Worksheets("Sheet2").Columns(col), _
            Worksheets("Sheet2").Columns(col + 2), Worksheets("Sheet2").Columns(col + 4), _
            Worksheets("Sheet2").Columns(col + 7), Worksheets("Sheet2").Columns(col + 10), _
            Worksheets("Sheet2").Columns(col + 12)))

                 For Each elt In sel
                    If elt.Value > Mini Then
                        If elt.Column <= col + 4 Then
                            elt.Offset(0, 1).Insert shift:=xlShiftDown
                        ElseIf elt.Column >= col + 10 Then
                            elt.Offset(0, -1).Insert shift:=xlShiftDown
                        ElseIf elt.Column = col + 7 Then
                            elt.Offset(0, 1).Insert shift:=xlShiftDown
                            elt.Offset(0, -1).Insert shift:=xlShiftDown
                        End If
                        elt.Insert shift:=xlShiftDown
                    End If
                Next
                lastRow = lastRow + 1
            End If

            curRow = curRow + 1
            mybool = True
            Mini = 0

        Loop

    End With

    Application.ScreenUpdating = True

End Sub

Answer 1

在没有正确查看代码的情况下，我们一直在指出更明显的语法错误。

您希望工作表的每一行都有此功能。我通常建议：

Dim x as Long

For x = RowStart to rowMax
  :   :   :
Next

但是，您要插入新行，因此无法使用For循环。我稍后会回到这个问题，暂时假设您可以使用For循环。

您不需要For Each c In Columns("a", "c", "e", "h", "k", "m")，因为您没有遍历这些列。

您需要的是：

For x = RowStart to rowMax
  If Cells(x, "a") = Cells(x, "c") And Cells(x, "c") = Cells(x, "e") And _
     Cells(x, "e") = Cells(x, "h") And Cells(x, "h") = Cells(x, "k") And _
     Cells(x, "k") = Cells(x, "m") Then
  Else
  :   :   :
  End If
Next

但是，这是不正确的，因为您有选择地向下移动值。

在您的示例中，A列不等于C列，因此您将C列向下移动到M.我假设如果A列等于C列但C列不等于E列，您可以将列E移动到M。如果列A，C和E相等，则列H到M向下移动。等等。

这种描述更接近您的要求吗？你能否列A，E，H，K和M等于C列不同？

一旦我确信我完全了解您的要求，我很乐意推荐一些我认为符合您要求的代码。

Answer 2

你能否确认列b，d，f，g，i，j和l中的范围应如何移动？他们应该直接在他们的右边或左边按照范围的模式吗？

我已经汇总了一些代码，这些代码可以满足您的要求 - 据我所知 - 对于列a，c，e，h，k，m，但我很困惑如何处理其余的。

编辑：以下工作

只是详细说明代码的逻辑，以便您可以更好地了解这是否实际涵盖了所有要求：

它遍历动态范围的每一行 - 由原始范围加上可能作为迭代过程的一部分添加到其中的任何新行，从原始范围向下移动一些单元格
对于每次迭代，例程查看当前行中A，C，E，H，K和M列的每个单元格中的值;对于这些单元格中的每一个，如果该值均高于组中的最小值且单元格不为空，则单元格向下移动 - 与从B，D，F，G列中的该单元格配对的任何单元格一起向下移动，我，J和L

以下是列配对的方式：A-B，C-D，E-F，G-H-I，J-K，L-M

此代码假定范围

中没有列标题

您需要在运行之前在评论标识的几个部分中填写YOUR_WORKSHEET_NAME和YOUR_RANGE_ADDRESS的名称：

Sub reshape_range()
    Dim lastRow As Integer
    Dim curRow As Integer
    Dim sel As Range
    Dim elt As Range
    Dim mybool As Boolean
    Dim Mini As Integer
    Dim col As Integer

    'ENTER YOUR_WORKSHEET_NAME AND YOUR_RANGE_ADDRESS HERE
    With Worksheets("YOUR_WORKSHEET_NAME").Range("YOUR_RANGE_ADDRESS")

        curRow = 1
        lastRow = .Rows.Count
        col = .Column
        mybool = True
        Mini = 0

        Application.ScreenUpdating = False

        Do While curRow < lastRow

            'ENTER YOUR_WORSHEET_NAME HERE
            Set sel = Intersect(.Rows(curRow), Union(Worksheets("YOUR_WORKSHEET_NAME").Columns(col), _
            Worksheets("YOUR_WORKSHEET_NAME").Columns(col + 2), Worksheets("YOUR_WORKSHEET_NAME").Columns(col + 4), _
            Worksheets("YOUR_WORKSHEET_NAME").Columns(col + 7), Worksheets("YOUR_WORKSHEET_NAME").Columns(col + 10), _
            Worksheets("YOUR_WORKSHEET_NAME").Columns(col + 12)))

            For Each elt In sel
                If elt.Value <> "" Then
                    If Mini = 0 Then
                        Mini = elt.Value
                    Else
                        If elt.Value <> Mini Then
                            mybool = False
                            If elt.Value < Mini Then Mini = elt.Value
                        End If
                    End If
                End If
            Next

            If Not mybool Then
                For Each elt In sel
                    If elt.Value > Mini Then
                        If elt.Column <= col + 4 Then
                            elt.Offset(0, 1).Insert shift:=xlShiftDown
                        ElseIf elt.Column >= col + 10 Then
                            elt.Offset(0, -1).Insert shift:=xlShiftDown
                        ElseIf elt.Column = col + 7 Then
                            elt.Offset(0, 1).Insert shift:=xlShiftDown
                            elt.Offset(0, -1).Insert shift:=xlShiftDown
                        End If
                        elt.Insert shift:=xlShiftDown
                    End If
                Next
                lastRow = lastRow + 1
            End If

            curRow = curRow + 1
            mybool = True
            Mini = 0

        Loop

    End With

    Application.ScreenUpdating = True

End Sub

根据行中的值更改选择并移动单元格

2 个答案: