Excel 2010 VBA：根據兩個相鄰單元格的比較插入空白單元格

Question

我有兩個需要排序的鏈表。 為了簡化測試，我僅在每個列表中使用13個項目，其中包含詩人和科學家的名字。 我真正的電子表格有成千上萬的條目。

如果second_col和third_col （分別在此處的列B和C）中的值相同，則我希望它們（以及second_col third_col的名稱）顯示在同一行上。 如果B中的值小於C中的值，則我希望C和D中的空白單元格將較大的值及其相關的科學家姓名下移。 如果C中的值小於B中的值，則我希望A和B中的空白單元格。

我從AD列開始...我期望在FI列...我得到的是KN列。

這是我用來執行此任務的代碼：

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 ...在這一點上，我已經失去了主意。

誰能幫我？

傑克·H

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

這是我正在嘗試改進的地方。 如果列A和列B都已排序並且B中的所有內容都在A中的某個位置，則此代碼有效。之前： 2列排序，之前

它有效，這是之后的After： 在此處輸入圖像描述

我還擴展了它，以便在第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