技巧篇：常用的vba代码汇总

技巧篇：常用的vba代码汇总

模块1：生成workbook下的目录

Attribute VB_Name = "Basic"
Option Explicit

Sub Generate_Content_General()

Application.ScreenUpdating = False
'第一部分：声明基础变量
Dim sht As Worksheet
Dim sht_content As Worksheet
Dim wk As Workbook

Set wk = ThisWorkbook
Set sht_content = wk.Sheets("目录")
With sht_content.Cells(2, 2)
    .Value = "目录"
    .Offset(0, 1) = "超链接"
End With

'第二部分：超链接
Dim i, j, k
Dim zstr, ystr, xstr

j = 2
i = 2
Do While i < wk.Sheets.Count
    Set sht = wk.Sheets(i)
    If sht.Name <> "目录" And sht.Visible = -1 Then
        With sht_content.Cells(j + 1, 2)
            .Value = sht.Name
            sht_content.Hyperlinks.Add .Offset(0, 1), Address:="", SubAddress:="'" & sht.Name & "'!a1", TextToDisplay:="点击链接表"
            '逆向链接过程
            j = j + 1
        End With
    End If
    i = i + 1
Loop

With sht_content.Range("b:c")
    .Columns.AutoFit
    .Font.Size = 12
End With

Application.ScreenUpdating = True
End Sub

模块2：移动目录到第一个位置

Sub move_sheet_index()


Dim wb As Workbook
Dim sht As Worksheet
Dim dht As Worksheet
Dim i
Dim sheet_name
Dim index

Set wb = ThisWorkbook
Set sht = wb.Sheets("目录")

For i = 2 To 38
    sheet_name = sht.Cells(i, 2)
    index = sht.Cells(i, 7)
    
    wb.Sheets(sheet_name).Move After:=Sheets(i - 1)
    
Next


End Sub

模块3：更新目录

Sub Update_Content()

Application.ScreenUpdating = False

Dim wk As Workbook
Dim sht_content As Worksheet

Set wk = ThisWorkbook
Set sht_content = wk.Sheets("目录")

    sht_content.Range("b:c").ClearContents
    
    Call Generate_Content_General

Application.ScreenUpdating = True

End Sub

模块4：取消隐藏单元格

Sub Cancel_Hidden()

Dim sht As Worksheet
For Each sht In Sheets

sht.Visible = xlSheetVisible

Next


End Sub

模块5：删除workbook下的代码模块

Sub 删除代码()   '这个程序要在标准的Moudle模块中
Dim i, icon
Dim vbc As Object
Dim wk As Workbook
Dim sht As Worksheet
Dim arr

Set wk = ThisWorkbook
Set sht = wk.Sheets("Draft")
icon = wk.VBProject.VBComponents.Count
ReDim arr(1 To icon, 2)
For i = 1 To icon
    If i > icon Then Exit For
    Set vbc = wk.VBProject.VBComponents(i)
'    arr(i, 0) = i
'    arr(i, 1) = vbc.Name
'    arr(i, 2) = vbc.Type
    
    If vbc.Type = 1 And vbc.Name <> "Delete_Model" And vbc.Name <> "Func" Then
            With Application.VBE.ActiveVBProject.VBComponents
                .Remove .Item(vbc.Name) '删除模块、类模块、窗体
            End With
            i = i - 1
            icon = icon - 1
    End If
Next

'sht.[a1].Resize(UBound(arr, 1), UBound(arr, 2) + 1) = arr

End Sub

模块6：vba中用sql模块

Function exe_sql(ds, sql As String)

Dim conn As Object
Dim spath$
Dim i As Integer, j, k%, t As Integer, Trow%, Tcolumn%
Dim columns, data
Dim rst As Object

Set conn = CreateObject("adodb.connection")
Set rst = CreateObject("adodb.recordset")

conn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;imex=1';data source= " & ds


If sql = "" Then
     MsgBox "请输入SQL语句"
     Exit Function
Else
    rst.Open sql, conn, 3
    i = rst.Fields.Count
    
    ReDim columns(1 To i)
    
    ' 记录获取的列名
    For k = 1 To i
        columns(k) = rst.Fields(k - 1).Name
    Next
    
    If rst.RecordCount > 0 Then j = rst.RecordCount
    
    ReDim data(1 To j, 1 To i)
    
    t = 1
    Do While rst.EOF = False
         For k = 1 To i
            If Not IsNull(rst.Fields(k - 1)) Then
               data(t, k) = rst.Fields(k - 1).Value
            End If
         Next
         rst.movenext
         t = t + 1
    Loop


End If


exe_sql = Array(columns, data)



End Function

模块7：通用的一些function

Function Extract(sql As String, f As String)

'#@@ 拽数，并返回数组
Dim cnn As Object, rst As Object
Dim r_arr, arr
Dim i, j
'#@@@@# 大前提
On Error GoTo Err_Handle
If sql = "" Then Extract = 0: Exit Function
'#@@@@# 正常执行
    Set cnn = CreateObject("adodb.connection")
    Set rst = CreateObject("adodb.recordset")
'    cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;HDR=YES';data source=" & f
    cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & f
'    cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;imex=1';data source= " & f
'#  imex=1 数据导入模式
    'rst = cnn.Execute(sql) | rng.copyfromrecordset rst | rst.fields.count | rst.recordcount
    rst.Open sql, cnn, 3
    i = rst.RecordCount
    If i <> "" And i >= 1 Then arr = rst.getrows(): rst.movefirst
    If Not IsArray(arr) Then Extract = Array("无记录"): Exit Function
    ReDim r_arr(UBound(arr, 2) + 1, UBound(arr, 1))
    i = rst.Fields.Count
    
'#@@@@# 这里属于标题部分
    For j = 1 To i
        r_arr(0, j - 1) = rst.Fields(j - 1).Name
    Next
    rst.movefirst
    rst.Close:    cnn.Close
    Set rst = Nothing:    Set cnn = Nothing
    
'#@@@@# 二维转换
    For j = 0 To UBound(arr, 2)
            For i = 0 To UBound(arr)
                    r_arr(j + 1, i) = arr(i, j)
            Next
    Next
    
    Extract = r_arr
    'Debug.Print "Over"
    Exit Function
'#@@@@# 错误提醒,on error resume next,on error goto err_handle,on error goto line,on error goto 0
Err_Handle:
    Extract = Err.Description

End Function

Function Extract_Origin(sql As String, f As String)

'#@@ 拽数，并返回数组
Dim cnn As Object, rst As Object
Dim r_arr, arr
Dim i, j
'#@@@@# 大前提
On Error GoTo Err_Handle
If sql = "" Then Extract_Origin = 0: Exit Function
'#@@@@# 正常执行
    Set cnn = CreateObject("adodb.connection")
    Set rst = CreateObject("adodb.recordset")
'    cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;HDR=YES';data source=" & f
    cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & f
'    cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;imex=1';data source= " & f
'#  imex=1 数据导入模式
    'rst = cnn.Execute(sql) | rng.copyfromrecordset rst | rst.fields.count | rst.recordcount
    rst.Open sql, cnn, 3
    If rst.RecordCount > 0 Then
        arr = rst.getrows
        ReDim r_arr(UBound(arr, 2), UBound(arr, 1))
        For j = 0 To UBound(arr, 2)
                For i = 0 To UBound(arr)
                        r_arr(j, i) = arr(i, j)
                Next
        Next
    Else
        r_arr = 0
    End If
        
    Extract_Origin = r_arr
    
    rst.Close
    cnn.Close
    
    Set rst = Nothing
    Set cnn = Nothing
    'Debug.Print "Over"
    Exit Function
'#@@@@# 错误提醒,on error resume next,on error goto err_handle,on error goto line,on error goto 0
Err_Handle:
    Extract_Origin = Err.Description

End Function


Function CheckWkOpen(ByVal f)

Dim tk As Workbook
Dim status

status = 0
For Each tk In Workbooks
      If StrComp(f, "book1.xls", 1) = 0 Then
            MsgBox f & " is open"
            Application.Windows(f).Visible = True
            Workbooks(f).Close False
            status = 1
      End If
Next

End Function

Function CheckFile(spath)

Dim fso As Object

Set fso = CreateObject("scripting.filesystemobject")

CheckExists = fso.fileexists(spath)

End Function

Function CheckTable(wk As Workbook, zstr As String)

Dim sht As Worksheet
Dim status
For Each sht In wk.Sheets
    If sht.Name = zstr Then
        status = 1
        Exit For
    Else
        status = 0
    End If
Next

CheckTable = status

End Function


Sub tt()

ActiveWorkbook.RemovePersonalInformation = False

End Sub

Function 拽数(sql As String, f As String)
'@@拽数，并返回数组
Dim cnn As Object, rst As Object
Dim r_arr, arr
Dim i, j
    Set cnn = CreateObject("adodb.connection")
    Set rst = CreateObject("adodb.recordset")
    cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source= " & f
    On Error GoTo Err_Handle
    rst.Open sql, cnn, 3
    i = rst.RecordCount
    If i <> "" And i >= 1 Then arr = rst.getrows(): rst.movefirst
    ReDim r_arr(UBound(arr, 2) + 1, UBound(arr, 1))
    i = rst.Fields.Count
    For j = 1 To i
        r_arr(0, j - 1) = rst.Fields(j - 1).Name
    Next
    rst.movefirst
    rst.Close
    cnn.Close
    Set rst = Nothing
    Set cnn = Nothing
    For j = 0 To UBound(arr, 2)
        For i = 0 To UBound(arr)
            r_arr(j + 1, i) = arr(i, j)
        Next
    Next
    拽数 = r_arr
    Set rst = Nothing
    Set cnn = Nothing
    Exit Function
Err_Handle:
    Debug.Print Err.Description
End Function

模块8：vba自动生成图表

Attribute VB_Name = "Generate_Chart"
Option Explicit

'=======================================下面为VBA自动生成部分=======================================
Sub Chart_Initial(C_row As Integer, C_column As Integer, ChartName As String, C_width As Integer, C_height)

'C_row,C_Column 存放行列位置,ChartName 存放表,C_width C_height 存放大小

Dim XTitle, YTitle
Dim Crng As Range, Xrng As Range, rng As Range
Dim sht As Worksheet, wb1 As Workbook
Dim MyChart As ChartObject
Dim R1, C, zstr

Set wb1 = ThisWorkbook
Set sht = wb1.Sheets("ChartData")

R1 = sht.ChartObjects.Count

If R1 > 0 Then
        For Each C In sht.ChartObjects
            zstr = C.Name
            If zstr = ChartName Then C.Delete
        Next
End If

'第一部分：创建一个新的图表Object事件
Set rng = sht.Cells(C_row, C_column)
Set MyChart = sht.ChartObjects.Add(rng.Left, rng.Offset(1, 0).Top, rng.Width * C_width, rng.Height * C_height)
With MyChart
        .Name = ChartName
End With

'第二部分：设置图表区格式
With MyChart.chart.ChartArea
        .Font.Name = "宋体"
        .Font.Size = 8
        .Font.ColorIndex = xlAutomatic
        .Border.LineStyle = 0
        .Interior.ColorIndex = xlAutomatic  '图表区填充
End With

'第三部分：设置绘图区格式
With MyChart.chart.PlotArea
        .Border.ColorIndex = 15
        .Border.Weight = xlThin
'        .Border.LineStyle = xlDot
        .Border.LineStyle = xlDot
        .Interior.ColorIndex = xlNone   '绘图区填充
End With

'第五部分：设置图表标题
MyChart.chart.HasTitle = True
With MyChart.chart.ChartTitle
        .Text = "<p>string</p>"
        .Font.Name = "宋体"
        .Font.Bold = True
        .Font.Size = 9
        .Top = 0
End With

End Sub

Sub Chart_FillData(MyChart As ChartObject, SerieName As String, Xrng As Range, Yrng As Range)

With MyChart.chart
        Dim ns
        Set ns = .SeriesCollection.NewSeries
        ns.Values = Xrng
        If Not Yrng Is Nothing Then ns.XValues = Yrng
        ns.Name = SerieName
End With
End Sub

Sub Chart_FinalStyle(MyChart As ChartObject)

With MyChart.chart
'        .ChartTitle.Left = (myChart.Chart.ChartArea.Width / 2) - (myChart.Chart.ChartTitle.Width / 2)
End With

End Sub

Sub Chart_Axes(MyChart As ChartObject)

MyChart.chart.Axes(xlValue).HasMajorGridlines = True
With MyChart.chart.Axes(xlValue).MajorGridlines.Border
            .ColorIndex = 15
            .Weight = xlHairline
            .LineStyle = xlDot
End With

End Sub

Sub Chart_SeriesPoint(MyChart As ChartObject, S1)

Dim ms As SeriesCollection
MyChart.Activate
ActiveChart.SeriesCollection(1).Points(S1).Select
With Selection.Format.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorAccent2
        .ForeColor.TintAndShade = 0
'        .ForeColor.Brightness = 0   '透明度设置 0.400000006=40%
        .Transparency = 0
        .Solid
End With
End Sub

Sub Chart_Transmit(ChartName As String, Gsht As Worksheet)

Dim C As ChartObject
Set C = Gsht.ChartObjects(ChartName)

With Gsht.Shapes(ChartName)
      .Fill.ForeColor.RGB = RGB(63, 74, 92)
'            .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255)
'            .Line.ForeColor.RGB = RGB(255, 0, 0)
'            .Line.ForeColor.ObjectThemeColor = msoThemeColorBackground1
End With
With C.chart.ChartArea
      .Font.ColorIndex = 2
      .Border.ColorIndex = 2
End With
C.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
'        C.Chart.Export C.Name & ".JPG"  '导出到文件路径文件夹
End Sub

Sub ChartToPicture(ChartName As String, Gsht As Worksheet, Grng As Range)
Dim C As ChartObject
Gsht.Select
Set C = Gsht.ChartObjects(ChartName)
C.Copy
Grng.Select
Gsht.PasteSpecial Format:="图片(JPEG)"
Call ShapeCheck("P" & ChartName, Gsht)
Selection.Name = "P" & ChartName
C.Delete
End Sub

Sub ChartCheck(ChartName As String, Gsht As Worksheet)

Dim R1, zstr
Dim C As ChartObject

R1 = Gsht.ChartObjects.Count

If R1 > 0 Then
        For Each C In Gsht.ChartObjects
            zstr = C.Name
            If zstr = ChartName Then C.Delete
        Next
End If

End Sub


Sub ShapeCheck(ShapeName As String, Gsht As Worksheet)

Dim R1, zstr
Dim s As Shape
R1 = Gsht.Shapes.Count

If R1 > 0 Then
        For Each s In Gsht.Shapes
            zstr = s.Name
            If zstr = ShapeName Then s.Delete
        Next
End If
End Sub



'Sub Chart_XY_Axes()

'第六部分：设置X\Y轴
'myChart.Chart.Axes(xlCategory, xlPrimary).HasTitle = True   'XlCategory是X轴
'mychart.Chart.Axes(xlCategory, xlPrimary).AxisTitle.Text = "X轴标题"
'With myChart.Chart.Axes(xlCategory, xlPrimary)
'            .CrossesAt = 0
'            .TickLabelSpacing = 1
'            .TickMarkSpacing = 1
'            .AxisBetweenCategories = True
'            .ReversePlotOrder = False
'End With
'myChart.Chart.Axes(xlValue, xlPrimary).HasTitle = True      'xlValue是Y轴
'myChart.Chart.Axes(xlValue, xlPrimary).AxisTitle.Text = "项目数"    '
'myChart.Chart.SetElement (msoElementPrimaryValueAxisTitleHorizontal)
'With myChart.Chart.Axes(xlValue, xlPrimary)
'            .MinimumScale = 0   '最小值
'            .MaximumScale = 10     '最大值
'            .MajorUnit = 2    '主要间距
'            .MinorUnit = xlAutomatic    '次要间距
'            .CrossesAt = 0      '坐标轴的交叉点
'            .ReversePlotOrder = False
'            .ScaleType = xlLinear
'End With


'第八部分：调整对比point的颜色
'Dim ms As SeriesCollection
'Set ms = myChart.Chart.SeriesCollection(1).points(1)
'End Sub

模块9：实现自动分级分组

Option Explicit

Sub group_by()

Application.ScreenUpdating = False

Dim sh_0 As Worksheet
Dim sh_1 As Worksheet
    
    Call loading_data
    
    Set sh_0 = ThisWorkbook.Sheets("res")
    Set sh_1 = ThisWorkbook.Sheets("structure")
    
    
    With sh_1
        With .Cells
            .Clear
            .Font.Size = 9
            .VerticalAlignment = xlCenter
            .RowHeight = 16.25
        End With
        .Select
        With .Rows(1)
            .Font.Bold = True
            .RowHeight = 22.75
        End With
        
        sh_0.Range("a:e").Copy
        .Range("a1").PasteSpecial (xlPasteValues)
    End With
    
    Call melt
    Call group
Application.ScreenUpdating = True

End Sub

Sub loading_data()

Dim sql$
Dim spath$
Dim arr
Dim sht As Worksheet

    Set sht = ThisWorkbook.Sheets("res")
    spath = ThisWorkbook.FullName
    sql = "select tb_sort,表名,业务,按业务分类,指标数 from("
    sql = sql + "Select tb_sort,表名,业务,按业务分类,count(1) as 指标数 ,b_sort,bc_sort from [indicator $] "
    sql = sql + "group by tb_sort,表名,业务,按业务分类,b_sort,bc_sort "
    sql = sql + "order by tb_sort ,b_sort,bc_sort) "

    arr = Extract(sql, spath)
    With sht
        .Cells.Clear
        .Range("A1").Resize(UBound(arr, 1) + 1, UBound(arr, 2) + 1) = arr
    End With

End Sub


Sub melt()

Dim nr, nc
Dim sh As Worksheet

    Set sh = ThisWorkbook.Sheets("structure")
    nc = sh.UsedRange.Columns.Count
    sh.Cells.ClearOutline
    sh.Range("a1:e1").Interior.Color = RGB(255, 217, 102)
    
Dim i, j, k
Dim ini_str, tmp_str
Dim tmp_c, tmp_end
Dim tmp_array

        tmp_array = Array(1, 3)
    
'    tmp_array = Array(4)
    j = LBound(tmp_array)
    
    Do While j <= UBound(tmp_array)
    
        tmp_c = tmp_array(j)
        
        i = 2
        Select Case tmp_c
        
            Case Is < 3:
                nr = sh.UsedRange.Rows.Count
                Do While i <= nr
                    If i = 2 Then
                        ini_str = sh.Cells(i, tmp_c)
                        With sh.Rows(i + 1)
                            .Insert Shift:=xlDown
                            sh.Cells(i + 1, tmp_c + 2) = sh.Cells(i, tmp_c + 2)
                            sh.Cells(i + 1, tmp_c + 3) = sh.Cells(i, tmp_c + 3)
                            sh.Cells(i + 1, tmp_c + 4) = sh.Cells(i, tmp_c + 4)
                            sh.Range(Cells(i, tmp_c + 2), Cells(i, tmp_c + 4)).Clear
                        End With
                        nr = nr + 1
                        i = i + 1
                    Else
                        tmp_str = sh.Cells(i, tmp_c)
                        If tmp_str = ini_str Then
                            sh.Range(Cells(i, tmp_c), Cells(i, tmp_c + 1)).Clear
                        Else
                            ini_str = tmp_str
                            With sh.Rows(i + 1)
                                .Insert Shift:=xlDown
                                sh.Cells(i + 1, tmp_c + 2) = sh.Cells(i, tmp_c + 2)
                                sh.Cells(i + 1, tmp_c + 3) = sh.Cells(i, tmp_c + 3)
                                sh.Cells(i + 1, tmp_c + 4) = sh.Cells(i, tmp_c + 4)
                                sh.Range(Cells(i, tmp_c + 2), Cells(i, tmp_c + 4)).Clear
                            End With
                            nr = nr + 1
                            i = i + 1
                        End If
                    End If
                    i = i + 1
                Loop
            Case Else:
                nr = sh.UsedRange.Rows.Count
                For k = 2 To nr
                    If sh.Cells(k, tmp_c - 1) <> "" Then
                        i = k + 1
                        With sh.Cells(i, tmp_c)
                            ini_str = .Value
                            If .Offset(1, 0) = "" Then
                                tmp_end = i
                            Else
                                tmp_end = .End(xlDown).Row
                            End If
                        End With
                        Do While i <= tmp_end
                            tmp_str = sh.Cells(i, tmp_c)
                            If tmp_str = ini_str And i = k + 1 Then
                                With sh.Rows(i + 1)
                                    .Insert Shift:=xlDown
                                    sh.Cells(i + 1, tmp_c + 1) = sh.Cells(i, tmp_c + 1)
                                    sh.Cells(i + 1, tmp_c + 2) = sh.Cells(i, tmp_c + 2)
                                    sh.Range(Cells(i, tmp_c + 1), Cells(i, tmp_c + 2)).Clear
                                End With
                                i = i + 1
                                nr = nr + 1
                                tmp_end = tmp_end + 1
                            Else
                                If tmp_str = ini_str Then
                                    sh.Cells(i, tmp_c).Clear
                                Else
                                    If tmp_str <> "" Then
                                        ini_str = tmp_str
                                        With sh.Rows(i + 1)
                                            .Insert Shift:=xlDown
                                            sh.Cells(i + 1, tmp_c + 1) = sh.Cells(i, tmp_c + 1)
                                            sh.Cells(i + 1, tmp_c + 2) = sh.Cells(i, tmp_c + 2)
                                            sh.Range(Cells(i, tmp_c + 1), Cells(i, tmp_c + 2)).Clear
                                        End With
                                        nr = nr + 1
                                        i = i + 1
                                        tmp_end = tmp_end + 1
                                    End If
                                End If
                            End If
                            i = i + 1
                        Loop
                        k = i - 1
                    End If
                Next
        End Select
        j = j + 1
    Loop
End Sub


Sub group()

Dim sht As Worksheet
Dim row_start%, row_end%
Dim target_column

    Set sht = Sheets("structure")
    row_start = 2
    target_column = "D"
'    row_end = sht.Cells(1048576, target_column).End(xlUp).Row + 1
    row_end = sht.UsedRange.Rows.Count
    
    sht.Cells.ClearOutline

Dim i
Dim refer_row%


    i = row_start
    refer_row = row_start
    Do While i <= row_end
        If Cells(i, 1) <> "" Then
            With Range(Cells(i, 1), Cells(i, 5))
                .Interior.Color = RGB(208, 206, 206)
                .Font.Color = RGB(0, 0, 0)
                .Font.Bold = True
                With .Borders(xlEdgeTop)
                    .LineStyle = xlDash
                    .Color = RGB(166, 166, 166)
                End With
                With .Borders(xlEdgeBottom)
                    .LineStyle = xlDash
                    .Color = RGB(166, 166, 166)
                End With
                
            End With
        End If
        If Cells(i, 3) <> "" Then
            With Range(Cells(i, 3), Cells(i, 5))
                .Interior.Color = RGB(255, 242, 204)
                .Font.Color = RGB(0, 0, 0)
                .Font.Bold = True
                With .Borders(xlEdgeTop)
                    .LineStyle = xlDash
                    .Color = RGB(191, 191, 191)
                End With
                With .Borders(xlEdgeBottom)
                    .LineStyle = xlDash
                    .Color = RGB(191, 191, 191)
                End With
            End With
        End If
        
        If Cells(i, 4) <> "" Then
            With Range(Cells(i, 4), Cells(i, 5))
                .Interior.Color = RGB(255, 242, 204)
                .Font.Color = RGB(0, 0, 0)
                .Font.Bold = True
                With .Borders(xlEdgeTop)
                    .LineStyle = xlDash
                    .Color = RGB(191, 191, 191)
                End With
                With .Borders(xlEdgeBottom)
                    .LineStyle = xlDash
                    .Color = RGB(191, 191, 191)
                End With
            End With
        End If
        
        If Cells(i, 5) <> "" Then
            With Range(Cells(i, 5), Cells(i, 5))
                With .Borders(xlEdgeTop)
                    .LineStyle = xlDash
                    .Color = RGB(128, 128, 128)
                End With
                With .Borders(xlEdgeBottom)
                    .LineStyle = xlDash
                    .Color = RGB(128, 128, 128)
                End With
            End With
        End If
        
        If Cells(i, 1) = "" Then Rows(i).group
        i = i + 1
    Loop

    For i = row_start To row_end
        If Cells(i, 2) = "" And Cells(i, 3) = "" Then
            Rows(i).group
        End If
    Next
    
'    For i = row_start To row_end
'        If Cells(i, 3) = "" And Cells(i, 4) = "" Then
'            Rows(i).group
'        End If
'    Next
    
End Sub