VBA练习-复杂一点

 

'日期添加
Sub addDate(d)
    Dim rg As Range, dd As Date
    
    d = Split(d, "-")(0)
    d = Replace(d, ".", "/")
    dd = CDate(d)
    r = ActiveSheet.Range("a65536").End(xlUp).Row
    '[d2] = dd
    Dim i As Integer '一天8次课，循环4次结束一天
    i = 0
    For Each rg In Range("D2:D" & r)
        i = i + 1
        If i = 4 Then
            i = 0
            dd = rg.Offset(-1, 0).Value + 1
        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 = 2 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 - 1)).Value
            
        End If
   Next
End Sub
'删除空行
Sub delBlank()
    Dim c As Range, r As Integer
    r = Range("a1").CurrentRegion.Rows.Count
    
    For i = 2 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 2 Step -1
        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(1, 0).Select
            ActiveSheet.Paste
            
               '选中一个单元格
            obj.Range("a1").Select
        End If
    Next
    ws.Range("a1").Select
    
End Sub



Sub 生成周课表()
'
' 生成周课表 宏
'
' 快捷键: Ctrl+k
'
    Application.ScreenUpdating = False
    
    Const copycol = 28
    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 = 4 To upNo - 1
            curRow = 28 * (i - 4) + 2
            '简称
            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(1, 0).Select
            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
            '星期
            ws.Range("C2:AD2").Copy
            cws.Range("E65536").End(xlUp).Offset(1, 0).Select
            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
            
            
    
            '周序
            str = ws.Range("a" & i).Value
            cws.Range("a65536").End(xlUp).Offset(1, 0).Resize(copycol, 1).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(1, 0).Resize(cws.Range("a65536").End(xlUp).Row - 1, 1).Select
        Selection = str
        
        '页码
        str = ws.Range("aa65536").End(xlUp).Value
        cws.Range("J65536").End(xlUp).Offset(1, 0).Resize(cws.Range("a65536").End(xlUp).Row - 1, 1).Select
        Selection = str
        
        '查找
         r = ws.Range("a65536").End(xlUp).Row
        For k = upNo + 2 To r
            Set rg = ws.Range("g" & k)
            If Not IsEmpty(rg) And Not rg.MergeCells Then
                For g = 2 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) = 0 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 + 2 To lastRow - 1
       
        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 - 1)
                    If rg.Value = jc Then '找到
                        rg.Interior.ColorIndex = 39
                    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 + 2 To lastRow - 1
              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 - 1)
                            If rg.Value = jc Then '找到
                                curWs.Range(rg.Address).Interior.ColorIndex = 39
                            End If
                        Next
                    End If
              End If
           Next
           
        End If
        
    Next
    Application.ScreenUpdating = True
    
End Sub

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