VBA

Cập nhật Tables: RefreshDataTables

Chọn file: BrowseFiles

Search cell by rule: FindCellByRule

Truy vấn sheet

Sub xml_QueryTab(control As IRibbonControl)
    Call Application.Run("'C:\miniMis\miniSql.xlam'!Query_Tab")
End Sub

Sub xml_QueryTab(control As IRibbonControl)
    Call Application.Run("'C:\miniMis\miniSql.xlam'!Query_Workbooks")
End Sub

---

Mở file source

Sub xml_OpenSource(control As IRibbonControl)
    Call Application.Run("'C:\miniMis\miniSql.xlam'!OpenSource")
End Sub

---

Tính lại sheet

Sub xml_CalcSheet(control As IRibbonControl)
    Call Application.Run("'C:\miniMis\miniSql.xlam'!Enable_Calc_All_1")  'Calc_Sheet
End Sub

---

Gọi lệnh đồng bộ query trong sheet

RefreshDataTables

Thay đổi độ cao dòng

Private Sub AdjustRowHeight()
    ActiveSheet.Range(Range("B3")).Select
    Application.Run "'C:\miniMis\miniSql.xlam'!RowHeight"
End Sub

---

Thay đổi độ rộng cột

Private Sub AdjustColumnWidth()
    ActiveSheet.Range(Range("C2")).Select
    Application.Run "'C:\miniMis\miniSql.xlam'!ColumnWidth"
End Sub

Application.Assistant.DoAlert "Tiêu đê", "Nôi dung thông báo", 0, 4, 0, 0, 0

Function IsString2(val As Variant) As Boolean
  IsString2 = VarType(val) = vbString
End Function

Function Range2(ParamArray Range_() As Variant) As String
  Application.Volatile
  SplitChar = ","
  Dim r As Variant, t As String, strarray() As String, addressPart As String
  t = "" ' Initialize t as an empty string
  For Each r In Range_()
    addressPart = r.Address(0, 0, xlA1, True) ' Get the full address of the range
    strarray = Split(addressPart, "!")  ' Split the address by "!" and get the second part (if exists)
    If UBound(strarray) >= 1 Then
      addressPart = strarray(1) ' Get the second part
    End If
    t = t & IIf(Len(t) > 0, SplitChar, "") & addressPart ' Concatenate the results, adding splitchar only if t is not empty
  Next
  Range2 = t ' Return the final result
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
  Dim cell As Range
  If Not Intersect(Target, Me.Range([A1])) Is Nothing Then
  Application.EnableEvents = False
    For Each cell In Target
      If IsString2(cell.Value) Then
        pos = InStr(cell.Value, ";")
        If pos > 0 Then
          cell.Value = Left(cell.Value, pos - 1)
        End If
      End If
    Next cell
  Application.EnableEvents = True
  End If
End Sub

Private Sub HashCell(ws)
   Dim r As Range, c As Range
   Dim t As String
   Set r = ws.UsedRange
   For Each c In r
       t = c.Text
       If IsNumeric(c.Value) And (t = "#" Or t = "##" Or t = "###" Or t = "####" Or t = "#####" Or t = "#####" Or t = "######" Or t = "#######" Or t = "########" Or t = "#########" Or t = "##########" Or t = "###########" Or t = "############" Or t = "#############" Or t = "##############" Or t = "###############") Then c.ShrinkToFit = True
    Next c
End Sub

Private Sub HashCells()
    Dim ws As Worksheet, selectedSheet As Worksheet
    For Each selectedSheet In ActiveWindow.SelectedSheets
        Call HashCell(selectedSheet)
    Next selectedSheet
End Sub

Private Sub FitPrint()
    With ActiveSheet.PageSetup
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 100
    End With
End Sub

Sub xml_PublishAsExcel(control As IRibbonControl)
    Call PublishAsExcel
End Sub

Sub PublishAsExcel()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim filePath As String, fileName As String
    Dim lastRow As Long, i As Long
    Dim visibleArray() As Boolean

    Set wb1 = ActiveWorkbook
    filePath = wb1.Path & "\"
    
    fileName = wb1.Name
    fileName = Left(fileName, InStrRev(fileName, ".") - 1) ' Loai bo phan mo rong
    fileName = fileName & "_" & Format(Now, "yymmdd-hhmm") & ".xlsx"
    
    Set wb2 = Workbooks.Add
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    
    wb2.SaveAs fileName:=filePath & fileName, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    
    ' Duyet qua tung sheet trong workbook hien tai
    For Each ws1 In wb1.Sheets
        If Left(ws1.Name, 1) = ChrW(10022) Or Left(ws1.Name, 1) = ChrW(10023) Then
        Application.StatusBar = "Publishing sheet " & ws1.Name
            
            ' Tao sheet moi trong workbook moi
            Set ws2 = wb2.Sheets.Add(After:=wb2.Sheets(wb2.Sheets.count))
            
            ws2.Name = ws1.Name
            If Err.Number <> 0 Then ws2.Name = "Copy_" & ws1.Name
            On Error GoTo 0
            ws2.Tab.color = ws1.Tab.color
            
            ' Sao chep du lieu va dinh dang
            ws1.UsedRange.Copy
            ws2.Cells(1, 1).PasteSpecial xlPasteValues
            ws2.Cells(1, 1).PasteSpecial xlPasteFormats
            ws2.Cells(1, 1).PasteSpecial xlPasteColumnWidths
            Application.CutCopyMode = False ' Dung che do sao chep

            ' Sao chep cai dat trang
            With ws2.PageSetup
                .Orientation = ws1.PageSetup.Orientation
                .PaperSize = ws1.PageSetup.PaperSize
                .Zoom = ws1.PageSetup.Zoom
                .FitToPagesWide = ws1.PageSetup.FitToPagesWide
                .FitToPagesTall = ws1.PageSetup.FitToPagesTall

                ' Cai dat layout in
                .LeftMargin = ws1.PageSetup.LeftMargin
                .RightMargin = ws1.PageSetup.RightMargin
                .TopMargin = ws1.PageSetup.TopMargin
                .BottomMargin = ws1.PageSetup.BottomMargin
                .HeaderMargin = ws1.PageSetup.HeaderMargin
                .FooterMargin = ws1.PageSetup.FooterMargin
                .CenterHorizontally = ws1.PageSetup.CenterHorizontally
                .CenterVertically = ws1.PageSetup.CenterVertically

                ' Tieu de va chan trang
                .CenterHeader = ws1.PageSetup.CenterHeader
                .LeftHeader = ws1.PageSetup.LeftHeader
                .RightHeader = ws1.PageSetup.RightHeader
                .CenterFooter = ws1.PageSetup.CenterFooter
                .LeftFooter = ws1.PageSetup.LeftFooter
                .RightFooter = ws1.PageSetup.RightFooter
                .DifferentFirstPageHeaderFooter = ws1.PageSetup.DifferentFirstPageHeaderFooter
                .OddAndEvenPagesHeaderFooter = ws1.PageSetup.OddAndEvenPagesHeaderFooter

                ' In duong luoi va tieu de
                .PrintGridlines = ws1.PageSetup.PrintGridlines
                .PrintHeadings = ws1.PageSetup.PrintHeadings
                .PrintComments = ws1.PageSetup.PrintComments

                ' Cai dat trang in
                .PrintArea = ws1.PageSetup.PrintArea
                .Order = ws1.PageSetup.Order
                .AlignMarginsHeaderFooter = ws1.PageSetup.AlignMarginsHeaderFooter
            End With
            
            lastRow = ws1.Cells(ws1.Rows.count, 1).End(xlUp).Row
            ReDim visibleArray(1 To lastRow)
            For i = 1 To lastRow
                visibleArray(i) = ws1.Rows(i).Hidden
            Next i
            For i = 1 To lastRow
                ws2.Rows(i).Hidden = visibleArray(i)
            Next i
            
            Call FitPrint
            wb2.Activate
            ActiveWindow.View = xlPageBreakPreview
        End If
    Next ws1
    
    wb2.Activate
    Application.DisplayAlerts = False
    Sheets(1).Delete
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationSemiautomatic
    
    For Each ws2 In wb2.Worksheets
        ws2.Select
        Call HashCell(ws2)
        Range("A1").Select
    Next ws2
    Sheets(1).Select
    wb2.Save
    Application.Assistant.DoAlert title, "Ða xuât các sheet báo cáo ra file Excel mói", 0, 5, 0, 0, 0
    
End Sub

Sub PublishAsExcel2()
    Application.Run ("'C:\miniMis\miniSql.xlam'!CopySheet1")
End Sub

Sub PublishAsPDF()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim arrSheets() As String
    Dim i As Long
    Dim filePath As String, fileName As String
    Dim useSelectedSheets As Boolean

    Set wb = ActiveWorkbook
    filePath = wb.Path & "\"

    fileName = Left(wb.Name, InStrRev(wb.Name, ".") - 1)
    fileName = fileName & "_" & Format(Now, "yymmdd-hhmm") & ".pdf"

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    ' ===== 1. Kiem tra có dang chon nhieu sheet không =====
    If TypeName(ActiveWindow.SelectedSheets) = "Sheets" _
        And ActiveWindow.SelectedSheets.count >= 2 Then
        useSelectedSheets = True
    End If

    ' ===== 2. Lay danh sách sheet =====
    If useSelectedSheets Then
        ' ? Dùng sheet dang chon
        For Each ws In ActiveWindow.SelectedSheets
            i = i + 1
            ReDim Preserve arrSheets(1 To i)
            arrSheets(i) = ws.Name
        Next ws
    Else
        ' ? Dùng logic cu theo ký tu dac biet
        For Each ws In wb.Worksheets
            If Left(ws.Name, 1) = ChrW(10022) Or Left(ws.Name, 1) = ChrW(10023) Then
                i = i + 1
                ReDim Preserve arrSheets(1 To i)
                arrSheets(i) = ws.Name
            End If
        Next ws
    End If

    If i = 0 Then
        MsgBox "Không có sheet nào dê xuât PDF", vbExclamation
        GoTo ExitSub
    End If

    ' ===== 3. Xuat PDF =====
    wb.Worksheets(arrSheets).Select

    ActiveSheet.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        fileName:=filePath & fileName, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=True

    MsgBox "Ðã xuât PDF thành công", vbInformation

ExitSub:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    wb.Worksheets(arrSheets(1)).Select

End Sub

Private Sub TextBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Dim rng As Range
    
    On Error Resume Next
    Set rng = Application.InputBox( _
        Prompt:="Range:", _
        Title:="Select target", _
        Type:=8)
    On Error GoTo 0
    
    If Not rng Is Nothing Then
        TextBox.value = rng.Address
    End If
End Sub