欢迎使用CSDN-markdown编辑器

Sub RunGroup()
‘Test2 Macro
Dim Sbrange As Range, WKC1 As String, Str As String, R2 As Integer, C2 As Integer, R3 As Integer, C3 As Integer, R4 As Integer, C4 As Integer, WKC3 As Range
Dim Rtn As String, C1 As Integer, R1 As Integer, CF1 As Integer, RF1 As Integer, Cflag As String, Wkvalue As String, Wkvalue2 As String
Dim Strf As String
Dim Str1 As String
Dim Str2 As String

ActiveWorkbook.Sheets(5).SelectTTR = ActiveSheet.UseRange.Rows.Count + 1Set Sbrange = Range(Cells(1, 1), Cells(TTR, 1))ActiveWorkbook.Sheets(1).SelectTTR1 = ActiveSheet.UseRange.Rows.Count + 1TTC1 = ActiveSheet.UseRange.Columns.Count + 1

NextR:

For Each WKC1 In Sbrange    C1 = WKC1.Column    R1 = WKC1.Row    Sheet1.Range(Cells(1, 1), Cells(TTR1, TTC1)).Select    Str1 = Left(Trim(Strf), 2)    If Trim(WKC1.Value) <> " " And Not (IsEmpty(WKC1.Value)) Then        On Error Resume Next        Selection.Find(What:=Trim(WKC1.Value), After:=ActiveCell, LookIn:=xlFormulas, LookAt _            :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _            False, MatchByte:=False, SearchFormat:=False).Activate        CF1 = ActiveCell.Column        RF1 = ActiveCell.Row        C2 = CF1        R2 = RF1        Flag = "Y"        StrFlag = "Y"

NextF
If Flag <> “Y” Then
On Error Resume Next
Selection.Find(What:=Trim(WKC1.Value), After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False).Activate

            CF1 = ActiveCell.Column            RF1 = ActiveCell.Row        End If        If StrFlag = "Y" Then            GSCF1 = CF1            GSRF1 = RF1            StrFlg = "N"        End If        If CF1 = GSCF1 And RF1 - GPRF1 = 1 Then            GECF1 = CF1            GERF1 = RF1        Else            If RF1 <> GSRF1 Then                StrG = CStr(GSRF1) + ";" + CStr(GERF1)                Sheet1.Rows(StrG).EntireRow.Group                StrFlg = "Y"            End If        End If        GPCF1 = CF1        GPRF1 = RF1        If R1 > TTR Then            Flag = "N"            GoTo NextC        Else            If CF1 = C2 And RF1 = R2 And Flag <> "Y" Then                GoTo NextC            End If            Flag = "N"            GoTo NextF        End If    End If

NextC
Next

EndProc:

End Sub

Sub RunColor()
‘Test2 Macro
Dim Sbrange As Range, WKC1 As String, Str As String, R2 As Integer, C2 As Integer, R3 As Integer, C3 As Integer, R4 As Integer, C4 As Integer, WKC3 As Range
Dim Rtn As String, C1 As Integer, R1 As Integer, CF1 As Integer, RF1 As Integer, Cflag As String, Wkvalue As String, Wkvalue2 As String
Dim Strf As String
Dim Str1 As String
Dim Str2 As String

ActiveWorkbook.Sheets(4).SelectTTR = ActiveSheet.UseRange.Rows.Count + 1Set Sbrange = Range(Cells(1, 1), Cells(TTR, 1))ActiveWorkbook.Sheets(1).SelectTTR1 = ActiveSheet.UseRange.Rows.Count + 1TTC1 = ActiveSheet.UseRange.Columns.Count + 1

NextR:

For Each WKC1 In Sbrange    C1 = WKC1.Column    R1 = WKC1.Row    Sheet1.Range(Cells(1, 1), Cells(TTR1, TTC1)).Select    Str1 = Left(Trim(Strf), 2)    If Trim(WKC1.Value) <> " " And Not (IsEmpty(WKC1.Value)) Then        On Error Resume Next        Selection.Find(What:=Trim(WKC1.Value), After:=ActiveCell, LookIn:=xlFormulas, LookAt _            :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _            False, MatchByte:=False, SearchFormat:=False).Activate        CF1 = ActiveCell.Column        RF1 = ActiveCell.Row        C2 = CF1        R2 = RF1        Flag = "Y"        'StrFlag = "Y"

NextF
If Flag <> “Y” Then
On Error Resume Next
Selection.Find(What:=Trim(WKC1.Value), After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False).Activate

            CF1 = ActiveCell.Column            RF1 = ActiveCell.Row        End If        Str = CStr(RF1) + ":" + CStr(CF1)        R3 = Sheet4.Cells(R1, 2).Characters(Start:=1, Length:=5).Font.ColorIndex        With Sheet1.Rows(Str).EntireRow.Select.Font            .ColorIndex = R3        End With        If R1 > TTR Then            Flag = "N"            GoTo NextC        Else            If CF1 = C2 And RF1 = R2 And Flag <> "Y" Then                GoTo NextC            End If            Flag = "N"            GoTo NextF        End If    End If

NextC
Next

EndProc:

End Sub

Sub RunTxt()
‘Test2 Macro
Dim Sbrange As Range, WKC1 As String, Str As String, R2 As Integer, C2 As Integer, R3 As Integer, C3 As Integer, R4 As Integer, C4 As Integer, WKC3 As Range
Dim Rtn As String, C1 As Integer, R1 As Integer, CF1 As Integer, RF1 As Integer, Cflag As String, Wkvalue As String, Wkvalue2 As String
Dim Strf As String
Dim Str1 As String
Dim Str2 As String

ActiveWorkbook.Sheets(3).SelectTTR = ActiveSheet.UseRange.Rows.Count + 1Set Sbrange = Range(Cells(1, 1), Cells(TTR, 1))ActiveWorkbook.Sheets(1).SelectTTR1 = ActiveSheet.UseRange.Rows.Count + 1TTC1 = ActiveSheet.UseRange.Columns.Count + 1

NextR:

For Each WKC1 In Sbrange    C1 = WKC1.Column    R1 = WKC1.Row    Sheet1.Range(Cells(1, 1), Cells(TTR1, TTC1)).Select    Str1 = Left(Trim(Strf), 2)    If Trim(WKC1.Value) <> " " And Not (IsEmpty(WKC1.Value)) Then        On Error Resume Next        Selection.Find(What:=Trim(WKC1.Value), After:=ActiveCell, LookIn:=xlFormulas, LookAt _            :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _            False, MatchByte:=False, SearchFormat:=False).Activate        CF1 = ActiveCell.Column        RF1 = ActiveCell.Row        C2 = CF1        R2 = RF1        Flag = "Y"        'StrFlag = "Y"

NextF
If Flag <> “Y” Then
On Error Resume Next
Selection.Find(What:=Trim(WKC1.Value), After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False).Activate

            CF1 = ActiveCell.Column            RF1 = ActiveCell.Row        End If        Str = Sheets(3).Cells(R1, C1 + 1).Value        If Str = " " Then            Sheets(1).Cells(RF1, CF1 + 1).Value = Str        End If        If R1 > TTR Then            Flag = "N"            GoTo NextC        Else            If CF1 = C2 And RF1 = R2 And Flag <> "Y" Then                GoTo NextC            End If            Flag = "N"            GoTo NextF        End If    End If

NextC
Next

EndProc:

End Sub

Sub RunSR()
‘Test2 Macro
Dim Sbrange As Range, WKC1 As String, Str As String, R2 As Integer, C2 As Integer, R3 As Integer, C3 As Integer, R4 As Integer, C4 As Integer, WKC3 As Range
Dim Rtn As String, C1 As Integer, R1 As Integer, CF1 As Integer, RF1 As Integer, Cflag As String, Wkvalue As String, Wkvalue2 As String
Dim TTR As Integer, TTC As Integer
Dim Strf As String
Dim Str1 As String
Dim Str2 As String

ActiveWorkbook.Sheets(1).SelectSet Sbrange = Range(Cells(1, 4), Cells(65535, 1))

NextR:

Cflag = "N"For Each WKC1 In Sbrange    C1 = WKC1.Column    R1 = WKC1.Row    Range("C:C").Select    On Error Resume Next    Selection.Find(What:="BEGSR", After:=ActiveCell, LookIn:=xlFormulas, LookAt _            :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _            False, MatchByte:=False, SearchFormat:=False).Activate    CF1 = ActiveCell.Column    RF1 = ActiveCell.Row    If WKC1.Row > RF1 Then        TTC = ActiveSheet.UseRange.Columns.Count + 1        If C1 + 2 <= TTC Then             Set Sbrange = Range(Cells(1, C1 + 2), Cells(65535, C1 + 2))             Range(Cells(1, C1 + 2), Cells(65535, C1 + 2)).Select             GoTo NextR        Else             GoTo EndProc        End If    End If    Wkvalue = Trim(WKC1.Value)    If (IsEmpty(Wkvalue) Or Wkvalue = " ") Then    Else        C1 = WKC1.Column        R1 = WKC1.Row        Range("B:B").Select        Wkvalue = Trim(Cells(WKC1.Row, WKC1.Column - 1).Value)        If Wkvalue = "EXSR" Then            GoTo NextC        End If        On Error Resume Next        Fstr = Trim(WKC1.Value)        Selection.Find(What:=Fstr, After:=ActiveCell, LookIn:=xlFormulas, LookAt _            :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _            False, MatchByte:=False, SearchFormat:=False).Activate        If Error Then            GoTo NextC        End If

Next1:
If ActiveCell.Column = WKC1.Column And ActiveCell.Row = WKC1.Row Then
Exit For
End If

        Wkvalue = Trim(WKC1.Value)        Wkvalue2 = Trim(ActiveCell.Value)        If Wkvalue = Wkvalue2 Then            C2 = ActiveCell.Column            R2 = ActiveCell.Row            Range(Cells(R2, 3), Cells(65535, 3)).Select            Selection.Find(What:="ENDSR", After:=ActiveCell, LookIn:=xlFormulas, LookAt _            :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _            False, MatchByte:=False, SearchFormat:=False).Activate            If ActiveCell.Column = C2 And ActiveCell.Row = R2 Then               MsgBox "exception : No Endsr"               Exit For            End If            C3 = ActiveCell.Column            R3 = ActiveCell.Row            If (R3 - R2) > 1 Then                Str = CStr(R3 - R2 - 1) + ":" + CStr(1)                Cells(R2, C2).Select                Cells(R2, C2).Activate                ActiveCell.Offset(1, 0).Rows(Str).EntireRow.Select                Application.CutCopyMode = False                Selection.Copy                Cells(R1 + 1, C1).Select                Cells(R1 + 1, C1).Activate                ActiveCell.Offset(0, 0).Rows("1:1").EntireRow.Select                Selection.Insert Shift:=xlDown                Cells(R1 + 1, C1 - 1).Select                Cells(R1 + 1, C1 - 1).Activate                Str = CStr(R3 - R2 - 1) + ":" + CStr(2)                Range(Cells(R1 + 1, 3), Cells(R1 + 1, 3)).Offset(0, 0).Resize(R3 - R2 - 1, 2).Select                Selection.Cut                Cells(R1 + 1, C1 + 1).Select                ActiveSheet.Paste                Cflag = "Y'"             End If        Else            Selection.FindNext(After:=ActiveCell).Activate            GoTo Next1        End If    TTR = ActiveSheet.UseRange.Rows.Count + 1    If WKC1.Row > TTR Then        Set Sbrange = Range(Cells(1, C1 + 2), Cells(65535, C1 + 2))        Range(Cells(1, C1 + 2), Cells(65535, C1 + 2)).Select        GoTo NextR    End If    End If

NextC
Next

EndProc:

End Sub