Excel 2010 VBA：根据两个相邻单元格的比较插入空白单元格

Question

我有两个链接列表需要排序。为了简化测试，我只在每个列表中使用13个项目，其中包含诗人和科学家的名字。我的真实电子表格有数千个条目。

如果second_col和third_col（此处分别为B和C列）中的值相同，我希望它们（以及随附的名称）显示在同一行上。如果B中的值小于C中的值，我希望在C和D中放入空白单元格以移动该较大的值及其关联的科学家名称。如果C中的值小于B中的值，我想要A和B中的空白单元格。

我开始的是A-D列...我期望的是F-I列......我得到的是K-N列。

这是我用来执行此任务的代码：

Sub InsrtFBlnk()

Dim first_col As Range
Dim second_col As Range
Dim row As Integer

Set first_col = Range("A1:A26")
Set second_col = Range("B1:B26")
Set third_col = Range("C1:C26")
Set fourth_col = Range("D1:D26")

'Assuming no headers, so start at row 1 and go to 2-times the original length of the lists
For row = 1 To second_col.Rows.Count
    'Only compare and insert if both cells in second_col and third_col are not blank
    If Not (second_col.Cells(row, 1).Value = "" Or third_col.Cells(row, 1).Value = "") Then
        'If value in 2nd_col is greater than value in 3rd_col, insert blanks in 1st & 2nd cols
        If second_col.Cells(row, 1).Value > third_col.Cells(row, 1).Value Then
            second_col.Cells(row, 1).Select
            Selection.Insert Shift:=xlDown
            first_col.Cells(row, 1).Select
            Selection.Insert Shift:=xlDown
        End If
        'If value in 2nd_col is less than value in 3rd_col, insert blanks in 3rd & 4th cols
        If second_col.Cells(row, 1).Value < third_col.Cells(row, 1).Value Then
            third_col.Cells(row, 1).Select
            Selection.Insert Shift:=xlDown
            fourth_col.Cells(row, 1).Select
            Selection.Insert Shift:=xlDown
        End If
    'If either of the cells in 2nd_col or 3rd_col were blank, come here, end, and go to next row
    Else: End If
Next row

End Sub

我真的希望这只是按照我评论的方式工作......但显然它不是。 我已经尝试过在If Not行中我可以想到的所有测试...... IsEmpty，最后使用或不使用.Value ......此时我没有想法。

任何人都可以帮助我吗？

Jack H

===================

这是我试图改进的地方。如果列A和B都已排序且B中的所有内容都位于A中，则此代码有效。 之前：2-column sorting, Before

它有效，这是后 之后：enter image description here

如果有第3，第4，第5等列必须与B列中的数字保持在同一行，我还会扩展它以添加空格。

我认为如果第一个比较列中的数字不在第二个比较列中，我所做的修改会使这个工作方式相同。但显然，我没有考虑到某些因素。

Answer 1

这很有效。我输出到F列：I

Option Explicit
Public Sub ReplaceValues1()
    Application.ScreenUpdating = False

    With ThisWorkbook.Worksheets("Sheet1")
        Dim arr(), sList As Object, dictPoet As Object, dictScientist As Object, dictFinalScientist As Object, i As Long, currCell As Range

        arr = .Range("A1").CurrentRegion.Value
        Set sList = CreateObject("System.Collections.Sortedlist")
        Set dictPoet = CreateObject("Scripting.Dictionary")
        Set dictScientist = CreateObject("Scripting.Dictionary")
        Set dictFinalScientist = CreateObject("Scripting.Dictionary")

        For i = LBound(arr, 1) To UBound(arr, 1)
            If Not sList.Contains(arr(i, 2)) Then sList.Add arr(i, 2), arr(i, 1)
            If Not sList.Contains(arr(i, 3)) Then sList.Add arr(i, 3), arr(i, 4)
            If Not dictFinalScientist.exists(arr(i, 3)) Then dictFinalScientist.Add arr(i, 3), arr(i, 4)
        Next i

        For i = 0 To sList.Count - 1
            If Not IsError(Application.Match(sList.GetKey(i), Application.WorksheetFunction.Index(arr, 0, 2), 0)) Then
                dictPoet.Add sList.GetByIndex(i), sList.GetKey(i) 'name, number
            Else
                dictPoet.Add "rem_" & sList.GetKey(i), "rem_" & sList.GetKey(i)
            End If
            If Not IsError(Application.Match(sList.GetKey(i), Application.WorksheetFunction.Index(arr, 0, 3), 0)) Then
                dictScientist.Add sList.GetByIndex(i), sList.GetKey(i) 'name, number
            Else
                dictScientist.Add "rem_" & sList.GetKey(i), "rem_" & sList.GetKey(i) 'number, name
            End If
        Next i

        .Cells(1, "F").Resize(dictPoet.Count, 1) = Application.Transpose(dictPoet.keys)
        .Cells(1, "G").Resize(dictPoet.Count, 1) = Application.Transpose(dictPoet.Items)
        .Cells(1, "H").Resize(dictPoet.Count, 1) = Application.Transpose(dictScientist.Items)

        For Each currCell In .Cells(1, "I").Resize(dictPoet.Count, 1)
            If Not IsEmpty(currCell.Offset(, -1)) Then currCell = dictFinalScientist(currCell.Offset(, -1).Value)
        Next currCell

       .Range("F1:I1").Resize(dictPoet.Count, 4).Replace ("rem_*"), vbNullString, xlWhole
    End With
    Application.ScreenUpdating = True
End Sub

<强>输出：

正在运行代码：

版本2：

使用您的逻辑

Option Explicit

Public Sub InsrtFBlnk()

    Dim first_col As Range
    Dim second_Col As Range
    Dim row As Long
    Dim third_col As Range, fourth_col As Range

    With Worksheets("Sheet1")

        Set first_col = .Range("A1:A26")
        Set second_Col = .Range("B1:B26")
        Set third_col = .Range("C1:C26")
        Set fourth_col = .Range("D1:D26")

        For row = 1 To second_Col.Rows.Count  
            If Not (second_Col.Cells(row, 1).Value = vbNullString Or third_col.Cells(row, 1).Value = vbNullString) Then
                If second_Col.Cells(row, 1).Value > third_col.Cells(row, 1).Value Then
                    first_col.Cells(row, 1).Resize(, 2).Select
                    Selection.Insert Shift:=xlDown
                ElseIf second_Col.Cells(row, 1).Value < third_col.Cells(row, 1).Value Then
                    third_col.Cells(row, 1).Resize(, 2).Select
                    Selection.Insert Shift:=xlDown
                End If
            End If
        Next row
    End With

End Sub

我想知道您是否使用间隔开的列，在这种情况下，您可能需要在插入之前将列合并，如下所示：

Option Explicit

Public Sub InsrtFBlnk()

    Dim first_col As Range
    Dim second_Col As Range
    Dim row As Long
    Dim third_col As Range, fourth_col As Range

    With Worksheets("Sheet1")

        Set first_col = .Range("A1:A26")
        Set second_Col = .Range("B1:B26")
        Set third_col = .Range("C1:C26")
        Set fourth_col = .Range("D1:D26")

        For row = 1 To second_Col.Rows.Count
            If Not (second_Col.Cells(row, 1).Value = vbNullString Or third_col.Cells(row, 1).Value = vbNullString) Then
                If second_Col.Cells(row, 1).Value > third_col.Cells(row, 1).Value Then
                    Union(first_col.Cells(row, 1), second_Col.Cells(row, 1)).Select
                    Selection.Insert Shift:=xlDown
                ElseIf second_Col.Cells(row, 1).Value < third_col.Cells(row, 1).Value Then
                    Union(third_col.Cells(row, 1), fourth_col.Cells(row, 1)).Select
                    Selection.Insert Shift:=xlDown
                End If
            End If
        Next row
    End With
End Sub