excel - 如何按顺序对多列进行排序并使行合并为相同的值？

Question

我有一个非常粗略的代码，用于将列排序并将它们合并在一起，如我的代码所示。前 3 个块首先按 A 列排序，然后是 B 列，然后是 C 列。

我想要它，以便用户可以看到 A、B 和 C 列中的细分。A 列是材料，B 是材料变体，C 是制造方法，而不必逐行查看每个条目。

有没有一种更有效的方法来对列进行排序而不必通过 3 块代码？最后合并它们对我来说似乎效果不佳，并且行最终混合在一起并且没有正确排序。

Dim wsproc As Worksheet: Set wsproc = ThisWorkbook.Worksheets("Procurement Table")

For k3 = wsproc.UsedRange.Rows.Count To 2 Step -1
    For i3 = wsproc.UsedRange.Rows.Count To 2 Step -1
        If _
        wsproc.Cells(k3, 1).Value = wsproc.Cells(i3 - 1, 1).Value _
        Then
        wsproc.Rows(i3 - 1).Cut
        wsproc.Range("A1").End(xlDown).Offset(1, 0).EntireRow.Insert
        End If
    Next
Next

For k3 = wsproc.UsedRange.Rows.Count To 2 Step -1
    For i3 = wsproc.UsedRange.Rows.Count To 2 Step -1
        If _
        wsproc.Cells(k3, 1).Value = wsproc.Cells(i3 - 1, 1).Value _
        And wsproc.Cells(k3, 2).Value = wsproc.Cells(i3 - 1, 2).Value _
        Then
        wsproc.Rows(i3 - 1).Cut
        wsproc.Range("A1").End(xlDown).Offset(1, 0).EntireRow.Insert
        End If
    Next
Next

For k3 = wsproc.UsedRange.Rows.Count To 2 Step -1
    For i3 = wsproc.UsedRange.Rows.Count To 2 Step -1
        If _
        wsproc.Cells(k3, 1).Value = wsproc.Cells(i3 - 1, 1).Value _
        And wsproc.Cells(k3, 2).Value = wsproc.Cells(i3 - 1, 2).Value _
        And wsproc.Cells(k3, 3).Value = wsproc.Cells(i3 - 1, 3).Value _
        Then
        wsproc.Rows(i3 - 1).Cut
        wsproc.Range("A1").End(xlDown).Offset(1, 0).EntireRow.Insert
        End If
    Next
Next

'To merge duplicate rows column-wise
Dim p As Variant
Dim iArray As Variant
Dim l%

iArray = Array(1, 2, 3)
ActiveSheet.ListObjects(1).Unlist

For Each p In iArray
    For l = wsproc.UsedRange.Rows.Count To 2 Step -1
        If wsproc.Cells(l, p).Value = wsproc.Cells(l - 1, p).Value _
        Then
        wsproc.Range(wsproc.Cells(l, p), wsproc.Cells(l - 1, p)).Merge
        End If

    Next
Next p

标签： excelvba

Answer 1

范围排序

Sub Main

  Dim sheet as Worksheet: Set sheet = ThisWorkbook.Sheets("Sheet Name")

  Dim lastRow as Long
  Dim lastColumn as Integer
  Dim sheetRange as Range

  Dim sheetArray as Variant
  Dim mergeRangesArray as Variant

  Dim startRows as Variant
  Dim i as Long

  lastRow = sheet.UsedRange.Rows.Count
  lastColumn = sheet.UsedRange.Columns.Count

  'Assign the sheet's used range to a variable
  Set sheetRange = sheet.Range(sheet.Cells(1, 1), sheet.Cells(lastRow, lastColumn))

  'Use the Range.Sort method to sort
  sheetRange.Sort key1:=sheet.Range("A1:A" & lastRow), order1:=xlAscending, _
  key2:=sheet.Range("B1:B" & lastRow), order2:=xlAscending, _
  key3:=sheet.Range("C1:C" & lastRow), order3:=xlAscending, Header:=xlYes

  'Assign the sheet's range values to a 2D array
  sheetArray = sheetRange

  'Loop through the rows of the 2D array, and add ranges that need to be merged
  'to the mergeRangesArray. The mergeRangesArray is an array of strings which
  'are looped through at the end of the Sub to merge cells.
  'The string argument for Range() has a character limit of 255.
  startRows = Array(2, 2, 2)
  For i = 3 to lastRow
      If sheetArray(i, 1) <> sheetArray(i - 1, 1) Then
          If i - startRows(0) > 1 Then
              Call AddToRangeArray(mergeRangesArray, "A" & startRows(0) & ":A" & i - 1)
              If i - startRows(1) > 1 Then
                  Call AddToRangeArray(mergeRangesArray, "B" & startRows(1) & ":B" & i - 1)
              End If
              If i - startRows(2) > 1 Then
                  Call AddToRangeArray(mergeRangesArray, "C" & startRows(2) & ":C" & i - 1)
              End If
          End If
          startRows = Array(i, i, i)
      Else
        
          If sheetArray(i, 2) <> sheetArray(i - 1, 2) Then
              If i - startRows(1) > 1 Then
                  Call AddToRangeArray(mergeRangesArray, "B" & startRows(1) & ":B" & i - 1)
              End If
              startRows(1) = i
          End If
          If sheetArray(i, 3) <> sheetArray(i - 1, 3) Then
              If i - startRows(2) > 1 Then
                  Call AddToRangeArray(mergeRangesArray, "C" & startRows(2) & ":C" & i - 1)
              End If
              startRows(2) = i
          End If
      End If
  Next i
  If i - startRows(0) > 1 Then
      Call AddToRangeArray(mergeRangesArray, "A" & startRows(0) & ":A" & i - 1)
  End If
  If i - startRows(1) > 1 Then
      Call AddToRangeArray(mergeRangesArray, "B" & startRows(1) & ":B" & i - 1)
  End If
  If i - startRows(2) > 1 Then
      Call AddToRangeArray(mergeRangesArray, "C" & startRows(2) & ":C" & i - 1)
  End If
  Application.DisplayAlerts = False
  For i = 1 to UBound(mergeRangesArray)
      sheet.Range(mergeRangesArray(i)).Merge
  Next i
  Application.DisplayAlerts = True

End Sub

Sub AddToRangeArray(mergeRangesArray as variant, myString as string)

    Dim i as Integer
    Dim j as Integer
    
    If IsEmpty(mergeRangesArray) = False Then
        i = UBound(mergeRangesArray)
        j = Len(mergeRangesArray(i))
        
        If j + Len("," & myString) <= 255 Then
            mergeRangesArray(i) = mergeRangesArray(i) & "," & myString
        Else
            ReDim Preserve mergeRangesArray(1 to i + 1)
            mergeRangesArray(i + 1) = myString
        End If
    Else
        ReDim mergeRangesArray(1 to 1)
        mergeRangesArray(1) = myString
    End If

End Sub