1. Copy dữ liệu từ 1 file sang file khác
'Vi du 1: Copy vung du lieu tu 1 file ra file moi
Sub CopyFiletoAnotherWorkbook()
'Copy vung du lieu
Sheets("Vd 1").Range("B3:C10").Copy
'Tao file moi
Workbooks.Add
'Paste du lieu
ActiveSheet.Paste
'Tat canh bao
Application.DisplayAlerts = False
'Luu file
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\File moi.xlsx"
ActiveWorkbook.Close
'Bat lai canh bao
Application.DisplayAlerts = True
End Sub
2. Bỏ ẩn toàn bộ hàng và cột
'Vi du 2: Bo an toan bo hang cot
Sub ShowHiddenRows()
'Bo an cot
Columns.EntireColumn.Hidden = False
'Bo an hang
Rows.EntireRow.Hidden = False
End Sub
3. Xoá hàng và cột rỗng
'Vi du 3: Xoa hang rong va cot rong
Public Sub DeleteBlankRows()
'Khai bao bien
Dim SourceRange As Range
Dim EntireRow, EntireColumn As Range
Application.ScreenUpdating = False
'Gan bien la vung cell duoc chon
Set SourceRange = Application.Selection
'Kiem tra co vung nao duoc chon
If Not (SourceRange Is Nothing) Then
For I = SourceRange.Rows.Count To 1 Step -1
Set EntireRow = SourceRange.Cells(I, 1).EntireRow 'Hang I cot 1
If Application.WorksheetFunction.CountA(EntireRow) = 0 Then
EntireRow.Delete
End If
Next
For I = SourceRange.Columns.Count To 1 Step -1
Set EntireColumn = SourceRange.Cells(1, I).EntireColumn 'Hang 1 cot I
If Application.WorksheetFunction.CountA(EntireColumn) = 0 Then
EntireColumn.Delete
End If
Next
Application.ScreenUpdating = True
End If
End Sub
4. Tìm cell rỗng
'Vi du 4: tim cell rong
Sub FindEmptyCell()
ActiveCell.Offset(1, 0).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
End Sub
5. Thay thế cell rỗng
'Vi du 5: Thay the cell rong
Sub FindAndReplace()
'Khai bao bien
Dim MyRange As Range
Dim MyCell As Range
'Co luu file truoc thay doi khong?
Select Case MsgBox("Khong the undo hanh dong nay. " & _
"Luu workbook truoc?", vbYesNoCancel)
Case Is = vbYes
ThisWorkbook.Save
Case Is = vbCancel
Exit Sub
End Select
'Gan bien la vung duoc chon
Set MyRange = Selection
'Bat dau vong lap.
For Each MyCell In MyRange
'Kiem tra co phai la cell rong hay khong
If Len(MyCell.Value) = 0 Then
MyCell = 0
End If
'Kiem tra cell tiep theo
Next MyCell
End Sub
6. Xoá khoảng trống thừa
'Vi du 6: Xoa cac khoang trang thua
Sub TrimTheSpaces()
'Khai bao bien
Dim MyRange As Range
Dim MyCell As Range
'Co luu file truoc khi thuc hien thao tac khong
Select Case MsgBox("Khong the undo hanh dong nay. " & _
"Luu file truoc khong?", vbYesNoCancel)
Case Is = vbYes
ThisWorkbook.Save
Case Is = vbCancel
Exit Sub
End Select
'Dinh nghia vung muc tieu
Set MyRange = Selection
'Bat dau vong lap
For Each MyCell In MyRange
'Got khoang trang.
If Not IsEmpty(MyCell) Then
MyCell = Excel.WorksheetFunction.Trim(MyCell)
End If
'Kiem tra cell tiep theo
Next MyCell
End Sub
7. Tô màu những cell trùng nhau
'Vi du 7: To mau nhung cell trung nhau
Sub HighlightDuplicates()
'Khai bao bien
Dim MyRange As Range
Dim MyCell As Range
'Dinh nghia bien muc tieu
Set MyRange = Selection
'Bat dau vong lap
For Each MyCell In MyRange
'Kiem tra cell co trung voi cell nao khac khong.
If WorksheetFunction.CountIf(MyRange, MyCell.Value) > 1 Then
MyCell.Interior.ColorIndex = 36
End If
'Kiem tra cell tiep theo
Next MyCell
End Sub
7. Trích xuất từ ngẫu nhiên trông ô
'Vi du 8: Trich xuat tu (word) tu cell
Function FindWord(Source As String, Position As Integer) As String
On Error Resume Next
FindWord = Split(WorksheetFunction.Trim(Source), " ")(Position - 1)
On Error GoTo 0
End Function
Function FindWordRev(Source As String, Position As Integer) As String
Dim Arr() As String
Arr = VBA.Split(WorksheetFunction.Trim(Source), " ")
On Error Resume Next
FindWordRev = Arr(UBound(Arr) - Position + 1)
On Error GoTo 0
End Function
0 Nhận xét