如何满足多个列的条件汇总

liaozhc

满足多个列的条件汇总

liaozhc

满足其中一列的条件，就汇总在一起

一把小刀闯天下

'替换所有代码

Option Explicit

Dim data

Private Sub CommandButton1_Click()
  Dim i, j, k, n, m, cnt, datatemp
  ReDim arr(1 To UBound(data, 1), 5)
  cnt = UBound(data, 1): datatemp = data
  If CheckBox1.Value Then
    For i = 2 To UBound(datatemp, 1)
      For j = 5 To 7
        If datatemp(i, j) = ComboBox1.Text Then
          n = n + 1
          For k = 1 To 4: datatemp(n, k) = datatemp(i, k): Next
          datatemp(n, k) = ComboBox1.Text
          Exit For
        End If
    Next j, i
    cnt = n
  End If
  n = 0
  If CheckBox2.Value Then
    For i = 1 To cnt
      If datatemp(i, 4) = ComboBox2.Text Then
        n = n + 1
        For j = 1 To 5: datatemp(n, j) = datatemp(i, j): Next
      End If
    Next
    cnt = n
  End If
  n = 0
  If CheckBox3.Value Then
    For i = 1 To cnt
      If datatemp(i, 3) = ComboBox3.Text Then
        n = n + 1
        For j = 1 To 5: datatemp(n, j) = datatemp(i, j): Next
      End If
    Next
    cnt = n
  End If
  If cnt > 0 Then
    For i = 1 To cnt
      For j = 1 To 5
        arr(i, j) = datatemp(i, j)
    Next j, i
    Call bsort(arr, 1, cnt)
    For i = 1 To cnt: arr(i, 0) = i: Next
  End If
  With Sheets("sheet6").[a2]
    .Resize(Rows.Count - 1, UBound(arr, 2) + 1).ClearContents
    If cnt > 0 Then .Resize(cnt, UBound(arr, 2) + 1) = arr
  End With
End Sub

Private Sub CommandButton2_Click()
  Unload Me
End Sub

Private Sub UserForm_Initialize()
  Dim i, j, dic(2)
  For i = 0 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  data = Sheets("sheet1").UsedRange
  For i = 2 To UBound(data, 1)
    dic(1)(data(i, 4)) = vbNullString
    dic(2)(data(i, 3)) = vbNullString
    For j = 5 To 7
      dic(0)(data(i, j)) = vbNullString
  Next j, i
  For Each i In dic(0).keys: ComboBox1.AddItem i: Next: ComboBox1.ListIndex = 0
  For Each i In dic(1).keys: ComboBox2.AddItem i: Next: ComboBox2.ListIndex = 0
  For Each i In dic(2).keys: ComboBox3.AddItem i: Next: ComboBox3.ListIndex = 0
  CheckBox1.Value = 1: CheckBox2.Value = 1: CheckBox3.Value = 1
End Sub

Function bsort(arr, first, last)
  Dim i, j, k, kk, t, move As Boolean
  For i = first To last - 1
    For j = first To last + first - 1 - i
      For k = LBound(arr, 2) To UBound(arr, 2) - 1
        If arr(j, k) > arr(j + 1, k) Then
          For kk = k To UBound(arr, 2)
            t = arr(j, kk): arr(j, kk) = arr(j + 1, kk): arr(j + 1, kk) = t
          Next
          move = True: Exit For
        ElseIf arr(j, k) = arr(j + 1, k) Then
          If arr(j, k + 1) > arr(j + 1, k + 1) Then
            For kk = k + 1 To UBound(arr, 2)
              t = arr(j, kk): arr(j, kk) = arr(j + 1, kk): arr(j + 1, kk) = t
            Next
            move = True
          ElseIf arr(j, k + 1) < arr(j + 1, k + 1) Then
            Exit For
          End If
        Else
          Exit For
        End If
      Next k, j
      If Not move Then Exit For
    Next
End Function

liaozhc

多谢，多谢   @一把小刀闯天下

liaozhc

多谢，多谢，多谢

liaozhc

但是，还有点细节问题如果完善下，就更好了

lsc900707

liaozhc 发表于 2018-6-8 18:04
多谢，多谢，多谢

“多谢”再多，不如直接给别人“评分”：点击对方帖子右下角“评分”按提示操作即可。

liaozhc

一把小刀闯天下 发表于 2018-6-8 15:33
'替换所有代码

Option Explicit

多谢你，真的多谢你，但还有些细节完美下就更好了

liaozhc

一把小刀闯天下 发表于 2018-6-8 15:33
'替换所有代码

Option Explicit

多谢你，还有细节能完善下就好了

一把小刀闯天下

liaozhc 发表于 2018-6-8 18:05
但是，还有点细节问题如果完善下，就更好了

在end with 上面插入一行：

.Offset(-1).Resize(, 6) = Split("序号 学校名称 姓名 性别 类别 项目")