Lưu trữ danh mục: Uncategorized

Trong 1 sheet excel dài, người dùng có thể thiết lập 1 mục lục cho sheet bảng tính bằng kỹ thuật đặt tên vùng dữ liệu.

Sub TachNhom()

Dim myCell As Range
    Dim wks As Worksheet
    Dim DataBaseWks As Worksheet
    Dim ListRange As Range
    Dim dummyRng As Range
    Dim myDatabase As Range
    Dim TempWks As Worksheet
    Dim rsp As Integer
    Dim i As Long

    Const TopLeftCellOfDataBase As String = “A4”
    Const KeyColumn As String = “C”
    ‘muon tach cot nao thi dien ten cot do
 

    Set DataBaseWks = Worksheets(“DATA”)
    i = DataBaseWks.Range(TopLeftCellOfDataBase).Row – 1

    Set TempWks = Worksheets.Add

    With DataBaseWks
        Set dummyRng = .UsedRange
        Set myDatabase = .Range(TopLeftCellOfDataBase, _
                            .Cells.SpecialCells(xlCellTypeLastCell))
    End With

    With DataBaseWks
        Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=TempWks.Range(“A1”), _
            Unique:=True

        TempWks.Range(“D1“).Value = _
            .Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value
    End With

    With TempWks
        Set ListRange = .Range(“A2”, .Cells(.Rows.Count, “A”).End(xlUp))
    End With

    With ListRange
        .Sort Key1:=.Cells(1), Order1:=xlAscending, _
            Header:=xlNo, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom
    End With

    For Each myCell In ListRange.Cells
        If WksExists(myCell.Value) = False Then
            Set wks = Sheets.Add
            On Error Resume Next
            wks.Name = myCell.Value
            If Err.Number <> 0 Then
                MsgBox “Please rename: ” & wks.Name
                Err.Clear
             
            End If
            On Error GoTo 0
            wks.Move After:=Sheets(Sheets.Count)
        Else
            Set wks = Worksheets(myCell.Value)
            wks.Cells.Clear
        End If

        If rsp = 6 Then
          DataBaseWks.Rows(“1:” & i).Copy Destination:=wks.Range(“A1”)
        End If
     
        TempWks.Range(“D2”).Value = “=” & Chr(34) & “=” & myCell.Value & Chr(34)

        If rsp = 6 Then
          myDatabase.AdvancedFilter _
              Action:=xlFilterCopy, _
              CriteriaRange:=TempWks.Range(“D1:D2”), _
              CopyToRange:=wks.Range(“A1”).Offset(i, 0), _
              Unique:=False
        Else
          myDatabase.AdvancedFilter _
              Action:=xlFilterCopy, _
              CriteriaRange:=TempWks.Range(“D1:D2”), _
              CopyToRange:=wks.Range(“A1”), _
              Unique:=False
              Columns(“D:D”).ColumnWidth = 20
              Columns(“F:F”).ColumnWidth = 20
              Columns(“G:G”).ColumnWidth = 15
        End If
     
    Next myCell
 
    Application.DisplayAlerts = False
    TempWks.Delete
    Application.DisplayAlerts = True

    MsgBox “TÁCH  THÀNH  CÔNG”

End Sub
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

———————

code tách các sheet ra thành nhiều file tại 1 forder

Sub tachsheet()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sh As Worksheet
For Each sh In Worksheets
    sh.Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & sh.Name, 51

' Có thể đổi lại vị trí lư tại chỗ ""
    ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub  

Code tìm các file dữ liệu cần gộp
Sub GopfileTH()
    Dim FilesToOpen
    Dim x As Integer
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    FilesToOpen = Application.GetOpenFilename _
    (FileFilter:=”Microsoft Excel Files (*.xls*), *.xls*”, MultiSelect:=True, Title:=”Files to Merge”)
    If TypeName(FilesToOpen) = “Boolean” Then
        MsgBox “Khong co file nao duoc chon”
        GoTo ExitHandler
    End If
    x = 1
    While x <= UBound(FilesToOpen)
        Workbooks.Open Filename:=FilesToOpen(x)
        Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        x = x + 1
    Wend
ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

Code gộp file vừa chọn
Sub Gopfile()
    Dim FilesToOpen
    Dim Filetonghopmoi As Workbook
    Dim filedangmo As Workbook
    Dim strFilename As String
    Dim x As Integer
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    FilesToOpen = Application.GetOpenFilename _
    (FileFilter:=”Microsoft Excel Files (*.xls*), *.xls*”, MultiSelect:=True, Title:=”Files to Merge”)
    If TypeName(FilesToOpen) = “Boolean” Then
        MsgBox “Khong co file nao duoc chon”
        GoTo ExitHandler
    End If
   
‘=====
‘Tao file tong hop moi noi luu mac dinh ngoai desktop

    Set Filetonghopmoi = Workbooks.Add(xlWBATWorksheet)
    strFilename = Dir(“C:UsersAdministratorDesktop” & “*.xls”, vbNormal)
   
 
    x = 1
    While x <= UBound(FilesToOpen)
    Set filedangmo = Workbooks.Open(Filename:=FilesToOpen(x))
    Sheets(“PL”).Copy After:=Filetonghopmoi.Sheets(Filetonghopmoi.Sheets.Count)
    ‘Thay ten sheet can gop cho phu hop. o day dang gop tat ca cac sheet co ten “PL” o ca file da cho
    Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    filedangmo.Close False
   
    x = x + 1
    Wend

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

———
Code gộp sheet trong file
Option Explicit

‘ Tao chuc nang tim ra DONG cuoi cung

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:=”*”, After:=sh.Range(“A1”), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
On Error GoTo 0
End Function

‘ Tao chuc nang tim ra COT cuoi cung

Function Lastcol(sh As Worksheet)
On Error Resume Next
Lastcol = sh.Cells.Find(What:=”*”, After:=sh.Range(“A1”), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
On Error GoTo 0
End Function

‘ Tao lenh GOPSHEET

Sub gopsheet()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

‘ XÓA bo sheet TONGHOP neu no da duoc thiet lap

Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets(“TONGHOP”).Delete
On Error GoTo 0
Application.DisplayAlerts = True

‘ TAO 1 sheet moi ten TONGHOP

Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = “TONGHOP”

‘Nhap dong bat dau

StartRow = 2

‘ Chay qua tat cac cac sheet  va thuc hien copy du lieu vao sheet TONGHOP

For Each sh In ActiveWorkbook.Worksheets
   If sh.Name <> DestSh.Name Then
 
‘ Tim don cuoi cung trong sheet tong hop va sheet thanh phan

   Last = LastRow(DestSh)
   shLast = LastRow(sh)
 

‘ Thuc hien copy du kieu khi sheet du lieu KHONG RONG va dong CUOI > dong BAT DAU
           If shLast > 0 And shLast >= StartRow Then
             
‘ thiet lap VUNG can copy
           
            Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))

‘ Kiem tra xem sheet TONGHOP co du dong de copy sang khong

               If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                  MsgBox “Khong du dong trong bang TONGHOP de copy sang”
                  GoTo ExitTheSub
               End If

‘ Copy du lieu o dang GIA TRI
             
               CopyRng.Copy
               With DestSh.Cells(Last + 1, “A”)
                   .PasteSpecial xlPasteValues
                   .PasteSpecial xlPasteFormats
                   Application.CutCopyMode = False
               End With

           End If

       End If
 
   Next

ExitTheSub:

   Application.GoTo DestSh.Cells(1)

   ‘ Tu dong dieu chinh so cot theo sheet TONGHOP
 
 
   DestSh.Columns.AutoFit

   With Application
       .ScreenUpdating = True
       .EnableEvents = True
   End With
End Sub

————-
Code xóa hết các sheet vừa thêm
‘————————-
Sub XoaSheetVuaThem()
‘
Application.DisplayAlerts = False
Dim sh As Worksheet
For Each sh In Worksheets
If sh.Name <> ActiveSheet.Name Then
sh.Delete
End If
Next sh
Application.DisplayAlerts = True

End Sub

VBA chưa hỗ trợ với bộ Unicode, Các ký tự hỗ trợ trong bảng mã Unicode mới chỉ được từ 0- 225 thôi. Nên các ký tự có mã unicode nhiều hơn sẽ hiển thị dấu (? )
Bởi vậy, để có thể gõ được tiếng việt trong VBA ta thực hiện theo 1 số cách thủ công như sau:
1. Gõ nội dung vào 1 ô trong bảng tính ( VD gõ vào ô A2) Thực hiện lệnh truy xuất nội dung của ô A2: Cells(1,2) = Sheets(“Sheet1”).cells(1,2).  Nhược điểm là các ô trong sheet phải có dữ liệu. Nếu vô tình xóa đi thì dữ liệu cũng sẽ mất.

2: Sử dụng phép nối chuỗi và hàm Chrw để viết code. VD: Viết chữ Lập trình = “L”&chrw(7853)&”p trình”. Đối với cách này mình phải nhớ và biết được bảng mã unicode cuả từng ký tự. Có thể dựa vào Bảng mã để tham chiếu

3. Sử dụng 1 hàm tự tạo (UniVBa) để dịch lại nội dung gõ trong sheet ra bảng Unicode. Từ đó nhập bản dịch vào bảng lập trình ( quay trở lại cách 2).
Đoạn code dịch như sau:

Function UniVba(TxtUni As String) As String
If TxtUni = “” Then
  UniVba = “”””””
Else
  TxtUni = TxtUni & ” “
  If AscW(Left(TxtUni, 1)) < 256 Then UniVba = “”””
  For n = 1 To Len(TxtUni) – 1
    uni1 = Mid(TxtUni, n, 1)
    uni2 = AscW(Mid(TxtUni, n + 1, 1))
    If AscW(uni1) > 255 And uni2 > 255 Then
      UniVba = UniVba & “ChrW(” & AscW(uni1) & “) & “
    ElseIf AscW(uni1) > 255 And uni2 < 256 Then
      UniVba = UniVba & “ChrW(” & AscW(uni1) & “) & “””
    ElseIf AscW(uni1) < 256 And uni2 > 255 Then
      UniVba = UniVba & uni1 & “”” & “
    Else
      UniVba = UniVba & uni1
    End If
  Next
  If Right(UniVba, 4) = ” & “”” Then
    UniVba = Mid(UniVba, 1, Len(UniVba) – 4)
  Else
    UniVba = UniVba & “”””
  End If
End If
End Function