VBA练习-复杂一点

'日期添加
Sub addDate(d)
    Dim rg As Range, dd As Date

    d = Split(d, "-")()
    d = Replace(d, ".", "/")
    dd = CDate(d)
    r = ActiveSheet.Range("a65536").End(xlUp).Row
    '[d2] = dd
    Dim i As Integer '一天8次课，循环4次结束一天
    i =
    For Each rg In Range("D2:D" & r)
        i = i +
        If i =  Then
            i =
            dd = rg.Offset(-, ).Value +
        End If
        rg = dd
    Next
End Sub
'创建新表
Sub createsheet(sname)
    On Error Resume Next
    Set ws = Worksheets(sname)
    If ws Is Nothing Then
        Set ws = Worksheets.Add
        ws.Name = sname
    Else
        ws.Cells.Clear
    End If
    ws.Range("a1:j1") = Array("周序", "简称", "教学班次", "日期", "星期", "节次", "课程名称", "任课教员", "上课地点", "页码")
End Sub
'拆开合并单元格
Sub devideMerge()
    Dim r As Integer, rg As Range, i As Integer

    r = Range("a65536").End(xlUp).Row
    For i =  To r
        If (Range("e" & i).MergeCells) Then Range("e" & i).UnMerge
        tempValue = Range("e" & i).Value
        If (tempValue = "") Then
            Range("E" & i).Value = Range("e" & (i - )).Value

        End If
   Next
End Sub
'删除空行
Sub delBlank()
    Dim c As Range, r As Integer
    r = Range("a1").CurrentRegion.Rows.Count

    For i =  To r
        Set c = Range("b" & i)
        If c.MergeCells Then c.EntireRow.Delete
    Next

    r = Range("a1").CurrentRegion.Rows.Count

     For i = r To  Step -
        Set c = Range("b" & i)
        If c.MergeCells Or IsEmpty(c) Then c.EntireRow.Delete
    Next

End Sub
'生成总周课表
Sub totalSheet()
    On Error Resume Next
    strname = "总周课表"
     Dim ws As Worksheet, obj As Worksheet, r As Integer

    Set ws = Worksheets(strname)
    If ws Is Nothing Then
      Set ws = Worksheets.Add
       ws.Name = strname
    Else
        ws.Cells.Clear
    End If
    ws.Range("a1:j1") = Array("周序", "简称", "教学班次", "日期", "星期", "节次", "课程名称", "任课教员", "上课地点", "页码")

    For Each obj In Worksheets
        If (obj.Name <> strname And obj.Name Like "*-周课表") Then
             r = obj.UsedRange.Rows.Count

            obj.Select
            obj.Rows("2:" & r).Select
            Selection.Copy
            ws.Select
            ws.Range("a65536").End(xlUp).Offset(, ).Select
            ActiveSheet.Paste

               '选中一个单元格
            obj.Range("a1").Select
        End If
    Next
    ws.Range("a1").Select

End Sub

Sub 生成周课表()
'
' 生成周课表 宏
'
' 快捷键: Ctrl+k
'
    Application.ScreenUpdating = False

    Const copycol =
    Dim ws As Worksheet, cws As Worksheet, upNo As Integer, r As Integer, cname As String, rg As Range, str As String, curRow

    For Each ws In Worksheets
        '创建新表－周课表
        cname = ws.Name + "-周课表"
        createsheet cname
        Set cws = Worksheets(cname)

        upNo = ws.Range("a:a").Find("序号").Row

        '开始复制内容
        For i =  To upNo -
            curRow =  * (i - ) +
            '简称
            ws.Range("C" & i & ":AD" & i).Copy
            cws.Range("B" & curRow & ":B" & curRow * copycol).Select
            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
            '节次
            ws.Range("C3:AD3").Copy
            cws.Range("f65536").End(xlUp).Offset(, ).Select
            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
            '星期
            ws.Range("C2:AD2").Copy
            cws.Range("E65536").End(xlUp).Offset(, ).Select
            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True

            '周序
            str = ws.Range("a" & i).Value
            cws.Range("a65536").End(xlUp).Offset(, ).Resize(copycol, ).Select
            Selection = str

        Next
        '日期处理
        cws.Select
        addDate ws.Range("b4").Value

        '删除空行
        r = cws.Range("a65536").End(xlUp).Row
        delBlank

         '课程名称
        str = ws.Range("f1").Value
        cws.Range("C65536").End(xlUp).Offset(, ).Resize(cws.Range("a65536").End(xlUp).Row - , ).Select
        Selection = str

        '页码
        str = ws.Range("aa65536").End(xlUp).Value
        cws.Range("J65536").End(xlUp).Offset(, ).Resize(cws.Range("a65536").End(xlUp).Row - , ).Select
        Selection = str

        '查找
         r = ws.Range("a65536").End(xlUp).Row
        For k = upNo +  To r
            Set rg = ws.Range("g" & k)
            If Not IsEmpty(rg) And Not rg.MergeCells Then
                For g =  To cws.Range("b65536").End(xlUp).Row
                    Set crg = cws.Range("b" & g)
                    If (crg.Value = rg.Value) Then

                       cws.Range("G" & g) = ws.Range("b" & k).Value '课程名称
                       cws.Range("H" & g) = ws.Range("n" & k).Value   '任课教员
                       cws.Range("I" & g) = ws.Range("AA" & k).Value  '上课地点
                    End If
                Next
            End If
        Next
        '把星期重新分开
        devideMerge

        '添加边框
        cws.UsedRange.Borders.LineStyle = xlContinuous

    Next
    Application.ScreenUpdating = True

    '生成总周课表
    totalSheet
End Sub

Sub 查看上课情况()
    Application.ScreenUpdating = False

    Dim jc As String, username As String, startRow As Integer, lastRow As Integer

    Dim curWs As Worksheet, ws As Worksheet, rg As Range

    Set curWs = ActiveSheet

    username = curWs.Range("af2").Value
    If Len(username) =  Then
        MsgBox "请在AF2单元格添写上课教员"
        Range("af1") = "上课教员:"
        Range("af2").Select
        Exit Sub
    End If

    '标记当前活动表
    startRow = curWs.Range("a:a").Find("序号").Row
    lastRow = curWs.Range("a:a").Find("序号").End(xlDown).End(xlDown).Row
    'MsgBox startRow & ":" & lastRow
    '找教员上的课程简称
    For x = startRow +  To lastRow - 

        If (curWs.Range("n" & x).Value Like "*" & username & "*") Then

            jc = curWs.Range("g" & x).Value
           '简称不能为空
           If (jc <> "") Then
                '如果找到就从课表中寻找上的课并添加底色
                For Each rg In curWs.Range("c4:ad" & startRow - )
                    If rg.Value = jc Then '找到
                        rg.Interior.ColorIndex =
                    End If
                Next
            End If
        End If
    Next

MsgBox "表有" & Worksheets.Count

    '循环所有表除了本表外
    For Each ws In Worksheets
        If (ws.Name <> curWs.Name) Then
           startRow = ws.Range("a:a").Find("序号").Row
           lastRow = ws.Range("a:a").Find("序号").End(xlDown).End(xlDown).Row

           '找教员上的课程简称
           For i = startRow +  To lastRow -
              If (Range("n" & i).Value Like "*" & username & "*") Then

               jc = ws.Range("g" & i).Value
                '从所有单元格中找
                ' MsgBox jc
                    If (jc <> "") Then
                         For Each rg In ws.Range("c4:ad" & startRow - )
                            If rg.Value = jc Then '找到
                                curWs.Range(rg.Address).Interior.ColorIndex =
                            End If
                        Next
                    End If
              End If
           Next

        End If

    Next
    Application.ScreenUpdating = True

End Sub

'清楚背景色标记
Sub 清楚背景色标记()
   ActiveSheet.Cells.Interior.ColorIndex =
End Sub