Tools for Excel table # Add-Ins

[thidinh]

Có Bác nào vui lòng giải thik đoạn code dưới đây giúp nhà em không?
Có Tool nào tương tự Made in VietNam không?
Hik...............

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


Attribute VB_Name = "Guides"

------------------------------------------------
Option Explicit
Private Delineatore As clsDelineateSQ31
Sub prcGuides()
Dim b As CommandBarButton, bName As String
Static Linea As Integer
Dim Desactivar
Application.ScreenUpdating = True
DoEvents
If Linea = 0 Then
Set Delineatore = Nothing
Set Delineatore = New clsDelineateSQ31
Set Delineatore.excelApp = Application
Dim cel As Range
Set cel = Selection
If Not cel Is Nothing Then
CreateGuideSQ31 cel.Cells(1, 1)
End If
Linea = 1
Else
disableRulerSQ31
Linea = 0
End If
End Sub

Sub disableRulerSQ31()
On Error Resume Next
BorraGuidesHojaSQ31
Set Delineatore = Nothing
End Sub


Public Function CreateGuideSQ31(RNG As Range)
Application.ScreenUpdating = False
deleteAllRulersInSheetSQ31 RNG.Worksheet
Dim a As Range, beginCell As Range, endcell As Range
For Each a In RNG.Areas
If a.Cells.count = 1 Then
Set beginCell = Nothing
Set endcell = Nothing
HorizontalSQ31 RNG, beginCell, a, endcell
Set beginCell = Nothing
Set endcell = Nothing
VerticalSQ31 RNG, beginCell, a, endcell
End If
Next
Application.ScreenUpdating = True
DoEvents
End Function

Sub VerticalSQ31(RNG As Range, beginCell As Range, a As Range, endcell As Range)
On Error Resume Next
If RNG.Worksheet.Shapes("JABS V " & a.Column) Is Nothing Then
Dim r As Long
r = ActiveWindow.VisibleRange.Rows.count
Set beginCell = Application.Intersect(ActiveWindow.VisibleRange.Rows(1), a.EntireColumn)
Set endcell = Application.Intersect(ActiveWindow.VisibleRange.Rows(r), a.EntireColumn)
With RNG.Worksheet.Shapes.AddLine(beginCell.Left + beginCell.Width, _
beginCell.Top, _
endcell.Left + endcell.Width, _
endcell.Top + endcell.Height)
.Placement = xlMove
.name = "JABS V " & a.Column
If Application.VERSION < 12 Then
.Line.ForeColor.SchemeColor = 2
Else
.Line.ForeColor.SchemeColor = 74
End If
End With
End If
End Sub

Sub HorizontalSQ31(RNG As Range, beginCell As Range, a As Range, endcell As Range)
On Error Resume Next
If RNG.Worksheet.Shapes("JABS H " & a.Row) Is Nothing Then
Dim C As Long
C = ActiveWindow.VisibleRange.Columns.count
Set beginCell = Application.Intersect(ActiveWindow.VisibleRange.Columns(1), a.EntireRow)
Set endcell = Application.Intersect(ActiveWindow.VisibleRange.Columns(C), a.EntireRow)
With RNG.Worksheet.Shapes.AddLine(beginCell.Left, _
beginCell.Top + beginCell.Height, _
endcell.Left + endcell.Width, _
endcell.Top + endcell.Height)
.Placement = xlMove
.name = "JABS H " & a.Row
If Application.VERSION < 12 Then
.Line.ForeColor.SchemeColor = 2
Else
.Line.ForeColor.SchemeColor = 74
End If
End With
End If
End Sub

Public Function BorraGuidesHojaSQ31()
deleteAllRulersInSheetSQ31 ActiveSheet
End Function


Private Function deleteAllRulersInSheetSQ31(ws As Worksheet)
If ws Is Nothing Then Exit Function
Dim s As Shape
For Each s In ws.Shapes
If InStr(1, s.name, "JABS") Then
s.Delete
End If
Next
End Function

--------------------------------------------------------------
Source: http://www.jabsoft.com