excel 隔列排序填充公式！

2163kjh

wodewan 发表于 2020-7-29 16:17
40，43，46行有重复会有问题

嗯，果然如此，是当出现数值相同的时候匹配会出错！

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

2163kjh

小刀老师，谦虚实力，在下佩服

2163kjh

小刀老师，如果改成右侧左1-左18 右1-右18，上1-上18，下1-下18 就是框下字段后面，改成18-18-18-18列，后面的循环怎么改？

2163kjh

Option Explicit


Sub 测试()
    Dim arr, brr, mark, i, j, k, kk, m, t
    Dim ds, dw, dz, dy, dx, mk, xh, wz, wy, hh, zh, sl, dh, zm, eow As Integer
    Dim sn, x
    Sheets("预览").Rows("2:5000").Clear '清除预览工作表第二行往下所有的数据
    With Sheets("数据表")
        dw = .Range("下长").Column
        dz = .Range("定左").Column
        dy = .Range("定右").Column
        ds = .Range("定上").Column
        dx = .Range("定下").Column
        mk = .Range("门宽").Column
        wz = .Range("左开").Column
        wy = .Range("右开").Column
        hh = .Range("行号").Column
        zh = .Range("组号").Column
        sl = .Range("数量").Column
        dh = .Range("单号").Column
        zm = .Range("字母").Column
        sn = .Range("顺逆").Column
        eow = .Cells(1, sn).End(xlDown).row
        arr = .Cells(3, sn).Resize(eow - 2, dw - sn + 1).Value '表1-10列数据
        x = 18
        brr = .Cells(3, dw + 1).Resize(UBound(arr, 1), 4 * x).Value '表10列往后的数据
        mark = .Cells(1, dw + 1).Resize(, UBound(brr, 2)).Value '模具keys
    End With
    ReDim crr(1 To UBound(arr, 1) * 4, 1 To 6 + 2 * x)
    '建立动态数组crr为全部数值=6可以替换为数据前面总列数，意思是前面6列逐列赋值，后面x列
    '由于是一对一对的所以是两个两个的赋值即2x
    '4=后面有几组数据，本例中有四组数据，故=4
    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) '将crr1-3列赋值：序号+组好+总长，m为crr的行坐标
                For k = 4 To 6 'crr 第i行第4列-第6列，数量，樘号，子母列=值循环方式放入crr
                    crr(m, k) = arr(i, k) '4-6列赋值给crr
                Next
                For k = (j - 7) * x + 1 To (j - 7) * x + x 'crr数据列7-18列循环赋值
                    crr(m, 2 * (k - ((j - 7) * x + 1)) + 7) = mark(1, k) 'crr 模具 7’9‘11’13‘15’17列赋值
                    crr(m, 2 * (k - ((j - 7) * x + 1)) + 8) = IIf(brr(i, k) > 0, brr(i, k), 10 ^ 8) 'crr 位置 8，10，12，14，16，18列赋值且将0值替换为100000
                Next
                '====以上将当前行全部赋值完成，以下为排序去空行
                'MsgBox UBound(crr, 2)
                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
小刀老师，根据您给的代码，我拿来主义，直接copy啦，终于挪到我的表格上了，再三感谢！！！
还有做了些注解，花了好些功夫才理解了一半，下面没有注解的您能给解释下吗，实在看不懂了!

2163kjh

一把小刀闯天下 发表于 2020-7-30 10:29
'纯粹是数格子哪来的研究，10楼附件，，，

Option Explicit

雾里看花，水中望月！此谓“水中月”，小刀老师，小弟受教了，感谢！

大镁铝

wodewan 发表于 2020-7-29 16:15
哈哈，果然如小刀老师所说，考眼力，40，43，46 行工序有重复，会有点问题，更新下
Sub test()
Dim arr,  ...

老师这个是关键字排序吗？list.Sort: ar = list.toarray这句两个我都没看懂

大镁铝

2163kjh 发表于 2020-7-30 23:38
Option Explicit

你没注释的for Step 2,是循环的步长，比如1，3，5

2163kjh

这个应该是list.sort，降序排序字典-----------然后将排好序的自动转换为数组ar，我是自己琢磨的，不知道对不对