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

呆呆鱼的天空

根据排班表的任课老师自动生成若干工作表，并按照格式展开
本人才开始接触VBA 看了好多VBA代码 自己操作总是不得章法
怎么也做不出来。请教！万分感谢 课程排班表.rar (17.41 KB, 下载次数: 18)

2019-12-29 23:04 上传

点击文件名下载附件
排班

呆呆鱼的天空

朱荣兴 发表于 2019-12-30 09:13
就是一个拆分问题，但是，不明白，为什么同一个人的课程还得分成多个工作表呢？？？

数据型式就是这个样子的

一把小刀闯天下

'输出到当前工作表了，因为你后面的规则可能有问题，自己可以再拆分。源数据可以无序，，，

Option Explicit

Sub test()
  Dim arr, i, j, k, p, pp, t, m, s
  With Sheets("排课表")
    arr = .Range("a1:e" & .Cells(Rows.Count, "a").End(xlUp).Row + 1)
    ReDim brr(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
        For j = 1 To UBound(brr, 2)
          brr(pp, j) = arr(1, j)
        Next
        p = i + 1: m = m + 3: pp = m
      End If
    Next
    .[h1].Resize(m + 1, UBound(brr, 2)) = brr
  End With
End Sub

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

麦子的虫虫

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. Dim i As integer, lsh As String, rng As Range, sht As Worksheet
   
3.     For Each sht In Worksheets
   
4.         If sht.Name <> "排课表" Then
   
5.             sht.Range("a2:d65536").ClearContents
   
6.         End If
   
7.     Next
   
8.    
   
9.     i = 2
   
10.     lsh = Worksheets("排课表").Cells(i, "A").Value
    
11.     Do While lsh <> ""
    
12.         Set rng = Worksheets(lsh).Range("A65536").End(xlUp).Offset(1, 0)
    
13.         Worksheets("排课表").Cells(i, "A").Resize(1, 4).Copy rng
    
14.         i = i + 1
    
15.         lsh = Worksheets("排课表").Cells(i, "A").Value
    
16.     Loop
    
17. End Sub

复制代码

呆呆鱼的天空

麦子的虫虫 发表于 2019-12-30 13:18

跪谢！！打开总是需要调试 是什么原因

呆呆鱼的天空

麦子的虫虫

呆呆鱼的天空 发表于 2019-12-30 14:08

我的运行正常啊

呆呆鱼的天空

麦子的虫虫 发表于 2019-12-30 15:01
我的运行正常啊

显示下标越界

呆呆鱼的天空

[img][/img]