Sorting 成对条目的水平排序

我的VBA技能是基本的。如果能帮我把数字排成一行，但移动相应的字符串，我将不胜感激。例如，这些行：

╔═══════╦═════════╦═══════╦═════════╗
║ Name1 ║ Number1 ║ Name2 ║ Number2 ║
╠═══════╬═════════╬═══════╬═════════╣
║ Joe   ║       5 ║ John  ║      10 ║
╚═══════╩═════════╩═══════╩═════════╝

应成为：

╔═══════╦═════════╦═══════╦═════════╗
║ Name1 ║ Number1 ║ Name2 ║ Number2 ║
╠═══════╬═════════╬═══════╬═════════╣
║ John  ║      10 ║ Joe   ║       5 ║
╚═══════╩═════════╩═══════╩═════════╝

我试图调整的代码是：

Sub hsort()
Dim lLast As Long, lLoop As Long
lLast = Cells(Rows.Count, 1).End(xlUp).Row
For lLoop = 2 To lLast
range(cells(lLoop,4),cells(lLoop,23)).Sort key1:=Cells(lLoop, 5), order1:=xlDescending,key2:=Cells(lLoop, 4), order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _False, Orientation:=xlLeftToRight, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
Next
End Sub

---

它首先对字符串进行排序，然后对数字进行排序，而不是根据需要将它们移动到一起。

假设Name1位于A1中，如果您在Name1和John之间临时添加一行，并使用=IFISEVENCOLUMN，A3，B3在它的复制，以适应你应该达到的顺序，我认为你想要一个正常的从左到右排序，然后可以删除临时行。如果您愿意，可以将其内置到VBA中。

最后，这是我采用的解决方案，但速度非常慢！是否有人对改进此代码有任何建议？字典对我来说似乎是一个很好的解决方案，但我不知道如何使用它，所以我问你们在这种情况下它是否可以实现

Sub Reorder()

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Dim i, c, j As Integer
i = 7

Do
j = 5
Do
Workbooks("Ownership Full v3.xlsx").Activate
Range(Cells(i, j), Cells(i, j + 1)).Copy
Workbooks("Book1.xlsx").Activate
If Range("A2") = blank Then
Range("A2").Select
Else
Range("A1").End(xlDown).Select
Selection.Offset(1, 0).Select
End If
ActiveSheet.Paste
j = j + 2
Workbooks("Ownership Full v3.xlsx").Activate
Loop While (j <= 23)

Workbooks("Book1.xlsx").Activate
    Range("B2:B11").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B2"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:B11")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
        End With


j = 5
c = 2
Do
Workbooks("Book1.xlsx").Activate
Range(Cells(c, 1), Cells(c, 2)).Cut
Workbooks("Ownership Full v3.xlsx").Activate
Cells(i, j).Select
ActiveSheet.Paste
c = c + 1
j = j + 2
Loop While (c <= 11)

i = i + 1

Loop While (Cells(i, 1) <> blank)

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With

End Sub

---

使用字典很容易，但正如@pnuts所指出的，它有点高级。我们在这里要做的是调用一个字典，将数据存储在那里，将它们传输到一个数组中，按降序对它们进行冒泡排序，将它们放回字典中，然后打印出来

呼。无论如何，该框架的成功归功于

不管怎样，先编码

'http://www.xl-central.com/sort-a-dictionary-by-item.html
Sub SortDictionaryByItem()

    'Set a reference to Microsoft Scripting Runtime by using
    'Tools > References in the Visual Basic Editor (Alt+F11)

    'Declare the variables
    Dim Dict As Scripting.Dictionary
    Dim Arr() As Variant
    Dim Temp1 As Variant
    Dim Temp2 As Variant
    Dim Txt As String
    Dim i As Long
    Dim j As Long
    Dim LastCol As Long, Iter As Long, Iter2 As Long, Iter3 As Long

    'Create an instance of the Dictionary
    Set Dict = New Dictionary

    'Set the comparison mode to perform a textual comparison
    Dict.CompareMode = TextCompare

    '''''''''''''''''BK201's Mod'''''''''''''''''

    'Get the last column of the row.
    LastCol = Range("A1").End(xlToRight).Column 'Modify accordingly.
    'Add keys and items to the Dictionary
    For Iter = 1 To (LastCol - 1) Step 2
        Dict.Add Cells(1, Iter).Value, Cells(1, Iter + 1).Value
    Next Iter
    '''''''''''''''''BK201's Mod'''''''''''''''''

    'Allocate storage space for the dynamic array
    ReDim Arr(0 To Dict.Count - 1, 0 To 1)

    'Fill the array with the keys and items from the Dictionary
    For i = 0 To Dict.Count - 1
        Arr(i, 0) = Dict.Keys(i)
        Arr(i, 1) = Dict.Items(i)
    Next i

    'Sort the array using the bubble sort method
    For i = LBound(Arr, 1) To UBound(Arr, 1) - 1
        For j = i + 1 To UBound(Arr, 1)
            If Arr(i, 1) < Arr(j, 1) Then
                Temp1 = Arr(j, 0)
                Temp2 = Arr(j, 1)
                Arr(j, 0) = Arr(i, 0)
                Arr(j, 1) = Arr(i, 1)
                Arr(i, 0) = Temp1
                Arr(i, 1) = Temp2
            End If
        Next j
    Next i

    'Clear the Dictionary
    Dict.RemoveAll

    'Add the sorted keys and items from the array back to the Dictionary
    For i = LBound(Arr, 1) To UBound(Arr, 1)
        Dict.Add Key:=Arr(i, 0), Item:=Arr(i, 1)
    Next i

    '''''''''''''''''BK201's Mod'''''''''''''''''
    'Change Cells(2, Iter2) to Cells(1, Iter2) to overwrite.
    KeyIndex = 0
    For Iter2 = 1 To (LastCol - 1) Step 2
        Cells(2, Iter2).Value = Dict.Keys(KeyIndex)
        KeyIndex = KeyIndex + 1
    Next Iter2

    For Iter3 = 2 To LastCol Step 2
        Cells(2, Iter3).Value = Dict.Item(Cells(2, Iter3 - 1).Value)
    Next Iter3
    '''''''''''''''''BK201's Mod'''''''''''''''''

    Set Dict = Nothing

End Sub

截图：

设立：

运行代码后的结果：

---

相应地修改涉及的范围。让我们知道这是否有帮助。

如果你想得到快速响应而不被否决，那么最好发布你尝试过的内容。你是指我已经尝试过的代码或类似于我的数据截图的内容？理想情况下两者都是。。。因为这将帮助用户解决确切的问题，而不是对整个问题进行编码。使用普通和直接排序是无法做到这一点的。我的建议是重新排列临时工作表中的数据，排序并粘贴回原始位置。使用VBA，您可以将数据存储在字典中，其中名称可以是键，数字可以是项。然后你可以对数据进行排序并粘贴到工作表上。我想我应该更好地解释我需要什么。我在第一行有从A1到X1的标题。前3列不得重新排序；然后我有5000行数据，我必须逐行排序。水平排序不起作用，因为它会对所有选定的单元格重新排序，而我需要的是，如果H列中的值较大，那么G列和H列都会移动到第1个位置，在我的情况下，这是D列，根据您上面的评论，只需将RangeA1.EndxlToRight.column更改为RangeA5.EndxlToRight.column就足够了。我没有费心重写，所以你可以直接看到它。在结尾附近检查注释，以了解覆盖所需的更改：是的，太好了，谢谢！但有一件事我不明白，我想问你。为什么在Dict.Item括号内的最后一次迭代中，您在字典中放置了一个比上一次迭代中的值更高的单元格速率？请注意这一点。基本上，我在这里假设了一件事：名称是唯一的。否则，将它们存储为密钥可能会导致错误。这是因为没有两个键可以具有完全相同的名称。现在，在最后两个迭代的第一个迭代中，我首先映射出已排序的名称。这些名称是键值。在第二次迭代中，为了确保只有相应的伙伴值返回给我们，我们使用名称访问字典的键值对中的值。这有意义吗基本上，Dict.Itemx从键x返回值。因为我们已经绘制了键和名称，剩下的就是得到它们各自的值。因此，我们在单元格上再次迭代，然后引用左侧相邻的单元格，其中包含name键，并使用它提取其伙伴值：这比使用数字索引获取项目要安全得多，无论从哪个角度看，这都会造成无限的悲伤D