excel 隔列排序填充公式！

2163kjh

一把小刀闯天下

'纯粹是数格子哪来的研究，10楼附件，，，

Option Explicit

Sub test()
  Dim arr, brr, mark, i, j, k, kk, m, t
  With Sheets("sheet1")
    arr = .Range("b3:k" & .[d3].End(xlDown).Row)
    brr = .[l3].Resize(UBound(arr, 1), 4 * 6).Value
    mark = .[l2].Resize(, UBound(brr, 2)).Value
  End With
  ReDim crr(1 To UBound(arr, 1) * 4, 1 To 6 + 2 * 6)
  For i = 1 To UBound(arr, 1)
    For j = 7 To 10
      If arr(i, j) > 0 Then
        m = m + 1: crr(m, 1) = m - 1: crr(m, 2) = arr(i, 3): crr(m, 3) = arr(i, j)
        For k = 4 To 6
          crr(m, k) = arr(i, k)
        Next
        For k = (j - 7) * 6 + 1 To (j - 7) * 6 + 6
          crr(m, 2 * (k - ((j - 7) * 6 + 1)) + 7) = mark(1, k)
          crr(m, 2 * (k - ((j - 7) * 6 + 1)) + 8) = IIf(brr(i, k) > 0, brr(i, k), 10 ^ 8)
        Next
        For k = 7 To UBound(crr, 2) - 3 Step 2
          For kk = 7 To UBound(crr, 2) + 4 - k Step 2
            If crr(m, kk + 1) > crr(m, kk + 3) Then
              t = crr(m, kk): crr(m, kk) = crr(m, kk + 2): crr(m, kk + 2) = t
              t = crr(m, kk + 1): crr(m, kk + 1) = crr(m, kk + 3): crr(m, kk + 3) = t
            End If
          Next
        Next
        For k = 8 To UBound(crr, 2) Step 2
          If crr(m, k) = 10 ^ 8 Then crr(m, k) = vbNullString: crr(m, k - 1) = crr(m, k)
        Next
      End If
    Next
  Next
  Sheets("预览").[a2].Resize(m, UBound(crr, 2)) = crr
End Sub

一把小刀闯天下

'练练眼力，，，

Option Explicit

Sub test()
  Dim arr(3), mark, i, j, k, t
  arr(0) = Range("b3:g" & Cells(Rows.Count, "b").End(xlUp).Row).Value
  mark = [b2].Resize(, UBound(arr(0), 2)).Value
  ReDim temp(1 To 2, 1 To UBound(arr(0), 2)), brr(1 To UBound(arr(0), 1), 1 To 2 * UBound(arr(0), 2))
  For i = 1 To UBound(arr)
    arr(i) = arr(0)
  Next
  For i = 1 To UBound(arr(0), 1)
    For j = 1 To UBound(arr(0), 2)
      temp(1, j) = arr(0)(i, j)
      temp(2, j) = mark(1, j)
      If temp(1, j) = 0 Then temp(1, j) = 10 ^ 8
    Next
    For j = 1 To UBound(temp, 2) - 1
      For k = j + 1 To UBound(temp, 2)
        If temp(1, j) > temp(1, k) Then
          t = temp(1, j): temp(1, j) = temp(1, k): temp(1, k) = t
          t = temp(2, j): temp(2, j) = temp(2, k): temp(2, k) = t
        End If
      Next
    Next
    For j = 1 To UBound(temp, 2)
      If temp(1, j) < 10 ^ 8 Then
        arr(1)(i, j) = temp(1, j)
        arr(2)(i, j) = temp(2, j)
        arr(3)(i, j) = temp(1, j) & "-" & temp(2, j)
        brr(i, 2 * j - 1) = temp(1, j)
        brr(i, 2 * j) = temp(2, j)
      Else
        For k = 1 To 3
          arr(k)(i, j) = vbNullString
        Next
      End If
    Next
  Next
  mark = Split("?,l,u,ae", ",")
  For i = 1 To 3
    Range(mark(i) & 3).Resize(UBound(arr(i), 1), UBound(arr(i), 2)) = arr(i)
  Next
  [ap3].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
End Sub

wodewan

Option Explicit
'不用你前面的4步转换，VBA 方式结果输出在BB列，供参考。
Sub test()
Dim arr, ar, br, res, i&, j&, k&, erow&
Dim list As Object: Set list = CreateObject("system.collections.arraylist")
Dim d As Object: Set d = CreateObject("scripting.dictionary")
With Sheets("sheet1")
    erow = .[a65533].End(3).Row
    br = .[b2:g2]
    arr = .Range("b3:g" & erow)
    ReDim res(1 To UBound(arr), UBound(arr, 2) * 2)
    For i = 1 To UBound(arr)
        For j = 1 To UBound(arr, 2)
            If arr(i, j) <> 0 Then
                list.Add (arr(i, j))
                d(arr(i, j)) = j
            End If
        Next
        list.Sort: ar = list.toarray
        For k = 0 To UBound(ar)
            res(i, k * 2) = ar(k)
            res(i, k * 2 + 1) = br(1, d(ar(k)))
        Next
        list.Clear
    Next
    .Range("bb3:bi1000").ClearContents
    .Range("BB3").Resize(UBound(res), UBound(res, 2)) = res
End With
End Sub

3190496160

直接出第四部结果不行吗

2163kjh

=IFERROR(IF(MOD(COLUMN(A1),2),INDEX($B$2:$G$2,MATCH(SMALL($B3:$G3,(COLUMN(A1)+1)/2+COUNTIF($B3:$G3,"0")),$B3:$G3,0)),SMALL($B3:$G3,COLUMN(A1)/2+COUNTIF($B3:$G3,"0"))),"") 直接输入这个公式可以左右上下拖拽直接生成，一键OK，详见附件！
还有啥更好的方法，集思广益~！

一把小刀闯天下

2163kjh 发表于 2020-7-29 07:45
=IFERROR(IF(MOD(COLUMN(A1),2),INDEX($B$2:$G$2,MATCH(SMALL($B3:$G3,(COLUMN(A1)+1)/2+COUNTIF($B3:$G3," ...

'你这最终示例结果中有3处是错误的，，，

Option Explicit

Sub test()
  Dim arr, i, j, k, t, mark
  arr = Range("b3:g" & [b3].End(xlDown).Row).Value
  mark = [b2].Resize(, UBound(arr, 2)).Value
  ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2) * 2)
  For i = 1 To UBound(arr, 1)
    For j = 1 To UBound(arr, 2)
      brr(i, 2 * j - 1) = IIf(arr(i, j) > 0, arr(i, j), 10 ^ 8)
      brr(i, 2 * j) = mark(1, j)
    Next
    For j = 1 To UBound(brr, 2) - 3 Step 2
      For k = 1 To UBound(brr, 2) - 2 - j Step 2
        If brr(i, k) > brr(i, k + 2) Then
          t = brr(i, k): brr(i, k) = brr(i, k + 2): brr(i, k + 2) = t
          t = brr(i, k + 1): brr(i, k + 1) = brr(i, k + 3): brr(i, k + 3) = t
        End If
      Next
    Next
    For j = 1 To UBound(brr, 2)
      If brr(i, j) = 10 ^ 8 Then brr(i, j) = vbNullString: brr(i, j + 1) = brr(i, j)
    Next
  Next
  [bm3].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
End Sub

2163kjh

6楼哪个地方有错误？能给指正下吗，一会我再把案例更改下让他在复杂点，在这基础上在研究下，表格局部排序！

wodewan

哈哈，果然如小刀老师所说，考眼力，40，43，46 行工序有重复，会有点问题，更新下
Sub test()
Dim arr, ar, s, res, i&, j&, k&, erow&
Dim list As Object: Set list = CreateObject("system.collections.arraylist")
With Sheets("sheet1")
    erow = .[a65533].End(3).Row
    arr = .Range("b2:g" & erow)
    ReDim res(1 To UBound(arr), UBound(arr, 2) * 2)
    For i = 2 To UBound(arr)
        For j = 1 To UBound(arr, 2)
            If arr(i, j) <> 0 Then
                s = Format(arr(i, j), "0000")
                list.Add (s & "-" & arr(1, j))
            End If
        Next
        list.Sort: ar = list.toarray
        For k = 0 To UBound(ar)
            res(i, k * 2) = Val(Split(ar(k), "-")(0))
            res(i, k * 2 + 1) = Split(ar(k), "-")(1)
        Next
        list.Clear
    Next
    .Range("bb3:bi1000").ClearContents
    .Range("BB2").Resize(UBound(res), UBound(res, 2)) = res
End With
End Sub

wodewan

2163kjh 发表于 2020-7-29 15:27
6楼哪个地方有错误？能给指正下吗，一会我再把案例更改下让他在复杂点，在这基础上在研究下，表格局部排序 ...

40，43，46行有重复会有问题

2163kjh

又加了些内容，谁愿意再研究下，谢谢，鲜花送上！