按特定条件生成表格并自动更新

麦子的虫虫

呆呆鱼的天空 发表于 2019-12-30 15:38
[/img]

不清楚，问下老师们吧，我也是新手

麦子的虫虫

也许是因为，你直接把代码复制到你自己的表格才出错的。
你把你表格的“二宝”“二宝1”工作表删掉

麦子的虫虫

我这个得按排课表里面的老师姓名，新建同名工作表。

莫名v微笑

尝试写了下，你看看能不能用

1. Sub aaa()
   
2. Application.ScreenUpdating = False
   
3. Application.DisplayAlerts = False
   
4. Dim a%, b%
   
5. Dim arr
   
6. Set d1 = CreateObject("scripting.dictionary")
   
7. Set d2 = CreateObject("scripting.dictionary")
   
8. arr = Sheets("排课表").UsedRange
   
9. If Sheets.Count > 1 Then
   
10.     For i = 2 To Sheets.Count
    
11.         Sheets(i).Delete
    
12.     Next
    
13. End If
    
14. For i = 2 To UBound(arr)
    
15. If Not d1.exists(arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3)) Then
    
16.     d1(arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3)) = arr(i, 4)
    
17. Else:
    
18.     d1(arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3)) = d1(arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3)) & Chr(10) & arr(i, 4)
    
19. End If
    
20. Next
    
21. For i = 2 To UBound(arr)
    
22. If Not d2.exists(arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3)) Then
    
23.     If Not d2.exists(arr(i, 1)) Then
    
24.         a = Sheets.Count + 1
    
25.         Sheets.Add After:=Sheets(a - 1)
    
26.         With Sheets(a)
    
27.         Sheets(a).Name = arr(i, 1)
    
28.         Sheets(1).Rows(1).Copy .Rows(1)
    
29.         Sheets(1).Rows(i).Copy .Rows(2)
    
30.         .Cells(2, 4) = d1(arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3))
    
31.         d2(arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3)) = 1
    
32.         d2(arr(i, 1)) = d2(arr(i, 1)) + 1
    
33.         End With
    
34.     Else:
    
35.         a = Sheets.Count + 1
    
36.         Sheets.Add After:=Sheets(a - 1)
    
37.         With Sheets(a)
    
38.         Sheets(a).Name = arr(i, 1) & d2(arr(i, 1))
    
39.         Sheets(1).Rows(1).Copy .Rows(1)
    
40.         Sheets(1).Rows(i).Copy .Rows(2)
    
41.         .Cells(2, 4) = d1(arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3))
    
42.         d2(arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3)) = 1
    
43.         d2(arr(i, 1)) = d2(arr(i, 1)) + 1
    
44.         End With
    
45.     End If
    
46. End If
    
47. Next
    
48. Erase arr
    
49. Set d1 = Nothing
    
50. Set d2 = Nothing
    
51. Application.ScreenUpdating = True
    
52. Application.DisplayAlerts = True
    
53. End Sub
    

复制代码

呆呆鱼的天空

一把小刀闯天下 发表于 2019-12-30 12:02
'输出到当前工作表了，因为你后面的规则可能有问题，自己可以再拆分。源数据可以无序，，，

Option Expl ...

谢谢 谢谢

呆呆鱼的天空

莫名v微笑 发表于 2019-12-30 16:54
尝试写了下，你看看能不能用

谢谢

呆呆鱼的天空

一把小刀闯天下 发表于 2019-12-30 12:02
'输出到当前工作表了，因为你后面的规则可能有问题，自己可以再拆分。源数据可以无序，，，

Option Expl ...

p = 2
    Call bsort(arr, 2, UBound(arr, 1) - 1, 1, UBound(arr, 2), 1)
    For i = 2 To UBound(arr, 1) - 1
      If arr(i, 1) <> arr(i + 1, 1) Then
        Call bsort(arr, p, i, 1, UBound(arr, 2), 2)
        For j = p To i
          If arr(j, 1) <> arr(j + 1, 1) Or arr(j, 2) <> arr(j + 1, 2) Then
            Call bsort(arr, p, j, 1, UBound(arr, 2), 5)
            For k = p To j
              s = s & vbNewLine & arr(k, 4)
              If arr(k, 1) <> arr(k + 1, 1) Or arr(k, 2) <> arr(k + 1, 2) Or arr(k, 5) <> arr(k + 1, 5) Then
                m = m + 1
                brr(m, 1) = arr(k, 1): brr(m, 2) = arr(k, 2): brr(m, 3) = arr(k, 3): brr(m, 4) = Mid(s, 2)
                p = k + 1: s = vbNullString
              End If
            Next
            p = j + 1
          End If
        Next
        For j = 1 To UBound(brr, 2)
          brr(pp, j) = arr(1, j)
        Next
        p = i + 1: m = m + 3: pp = m
      End If
到这里大概是什么意思 我试了一下 新加列 就不行了 ，我愚笨

呆呆鱼的天空

莫名v微笑 发表于 2019-12-30 16:54
尝试写了下，你看看能不能用

这个如果两个人选择同一课时 就只能显示出第一个人

一把小刀闯天下

呆呆鱼的天空 发表于 2019-12-31 14:26
p = 2
    Call bsort(arr, 2, UBound(arr, 1) - 1, 1, UBound(arr, 2), 1)
    For i = 2 To UBound(a ...

'1楼附件，按输出格式给你凑了一个，自己修改，，，

Option Explicit

Sub test()
  Dim arr, i, j, k, p, t, m, s, dic
  With Sheets("排课表")
    arr = .Range("a1:e" & .Cells(Rows.Count, "a").End(xlUp).Row + 1)
    ReDim brr(1 To UBound(arr, 1) * 4, 1 To 4)
    For i = 2 To UBound(arr, 1) - 1
      t = Replace(Replace(arr(i, 3), ":", "："), Space(1), vbNullString)
      t = Split(arr(i, 3), "-")
      arr(i, 5) = Format(Split(t(0), "：")(0), "00") & Format(Split(t(0), "：")(1), "00") & _
        Format(Split(t(1), ":")(0), "00") & Format(Split(t(1), ":")(1), "00")
    Next
    p = 2
    Call bsort(arr, 2, UBound(arr, 1) - 1, 1, UBound(arr, 2), 1)
    For i = 2 To UBound(arr, 1) - 1
      If arr(i, 1) <> arr(i + 1, 1) Then
        Call bsort(arr, p, i, 1, UBound(arr, 2), 2)
        For j = p To i
          If arr(j, 1) <> arr(j + 1, 1) Or arr(j, 2) <> arr(j + 1, 2) Then
            Call bsort(arr, p, j, 1, UBound(arr, 2), 5)
            For k = p To j
              s = s & vbNewLine & arr(k, 4)
              If arr(k, 1) <> arr(k + 1, 1) Or arr(k, 2) <> arr(k + 1, 2) Or arr(k, 5) <> arr(k + 1, 5) Then
                m = m + 1
                brr(m, 1) = arr(k, 1): brr(m, 2) = arr(k, 2): brr(m, 3) = arr(k, 3): brr(m, 4) = Mid(s, 2)
                p = k + 1: s = vbNullString
              End If
            Next
            p = j + 1
          End If
        Next
        p = i + 1
      End If
    Next
    Call doevent(False)
    Set p = Sheets("排课表").[a1:d1]
    Set dic = CreateObject("scripting.dictionary")
    For Each i In Sheets
      If i.Name <> "排课表" Then
        i.Delete
      End If
    Next
    For i = 1 To m
      If dic.exists(brr(i, 1)) Then
        dic(brr(i, 1)) = dic(brr(i, 1)) + 1
        s = brr(i, 1) & dic(brr(i, 1))
      Else
        s = brr(i, 1)
        dic(s) = 0
      End If
      Sheets.Add
      With ActiveSheet
        .Name = s
        p.Copy .[a1]
        For j = 1 To UBound(brr, 2)
          .Cells(2, j) = brr(i, j)
        Next
        .[a1].Resize(2, UBound(brr, 2)).Borders.LineStyle = xlContinuous
      End With
    Next
  End With
  Call doevent(True)
End Sub

Function doevent(flag As Boolean)
  With Application
    .DisplayAlerts = flag
    .ScreenUpdating = flag
  End With
End Function

Function bsort(arr, first, last, left, right, key)
  Dim i, j, k, t
  For i = first To last - 1
    For j = first To last + first - 1 - i
      If arr(j, key) > arr(j + 1, key) Then
        For k = left To right
          t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
        Next
      End If
    Next
  Next
End Function

呆呆鱼的天空

一把小刀闯天下 发表于 2019-12-31 14:53
'1楼附件，按输出格式给你凑了一个，自己修改，，，

Option Explicit

你咋这么好