Tổng hợp các code VBA cho Excel

Tổng hợp các đoạn code VAB cho Excel thường dùng, các bài ví dụ thực hành VBA cho Excel.

1. Code In Sheets trong 1 trang:

Sub FITPAGESTO_ONEPAGE()
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        With ws.PageSetup
            .PrintTitleRows = "$1:$2"
            .Zoom = False
            .FitToPagesWide = 1
            .FitToPagesTall = False
            .Orientation = xlLandscape
        End With
    Next
End Sub

2. Code đánh số thứ tự tự động khi có dữ liệu phát sinh:

- Dữ liệu phát sinh: cột B

- Vùng thay đổi số thứ tự cột A từ ô A2 đến dòng cuối của cột B

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rangeToChange As Range
Set rangeToChange = Range("B:B")

Dim i As Integer, STT As Integer
STT = 1

If Not Application.Intersect(rangeToChange, Range(Target.Address)) Is Nothing Then   'nếu ô B đựoc điền dữ liệu
    Range("A2:A" & Rows.Count).ClearContents 'Xoá STT cũ đi
    For i = 2 To Range("B" & Rows.Count).End(xlUp).Row    'lặp từ dòng 2 đến dòng cuối
        If Range("B" & i).Value <> "" Then     'nếu B khác rỗng
            Range("A" & i).Value2 = STT          'điền số thứ tự
            STT = STT + 1              'tăng STT lên 1 để cho ô kế tiếp
        End If
    Next i
End If

End Sub

3. Hàm concatIf - nối text theo điều kiện:

Hàm ConcatIF			To Concatenate multiple cells based on criteria
*	Sử dụng	Nối chuỗi có điều kiện
*	Cú pháp	=ConcatIf ( Delimiter , ConcateRange , CriteriaRange , Criteria)
*	Giải thích
		Tham số	Ý nghĩa	Kiểu giá trị
		Delimiter	Dấu phân cách	String
		ConcateRange	Vùng lấy giá trị	Range
		CriteriaRange	Vùng điều kiện	Range
		Criteria	Điều kiện so sánh	String

Function ConcatIf(delimiter As String, ConcateRange As Range, CriteriaRange As Range, Criteria As Variant) As String
Dim rng As Range
On Error Resume Next
ConcatIf = ""
For Each rng In CriteriaRange
If WorksheetFunction.CountIf(rng, Criteria) Then
ConcatIf = ConcatIf & delimiter & rng.Offset(0, ConcateRange.Column - CriteriaRange.Column)
End If
Next
ConcatIf = Mid(ConcatIf, Len(delimiter) + 1, Len(ConcatIf))
'Created by VuMinhHoan
End Function

4. Hàm xóa text trùng lặp trong 1 ô. (blog.hocexcel.online)

Function RemoveDupeWords(text As String, Optional delimiter As String = " ") As String

Dim dictionary As Object

Dim x, part

Set dictionary = CreateObject("Scripting.Dictionary")

dictionary.CompareMode = vbTextCompare

For Each x In Split(text, delimiter)

part = Trim(x)

If part <> "" And Not dictionary.Exists(part) Then

dictionary.Add part, Nothing

End If

If dictionary.Count > 0 Then

RemoveDupeWords = Join(dictionary.keys, delimiter)

Else

RemoveDupeWords = ""

End If

Set dictionary = Nothing

End Function

Cú pháp:

5. Xóa ký tự trùng lặp trong 1 ô. (blog.hocexcel.online)

Function RemoveDupeChars(text As String) As String

Dim dictionary As Object

Dim char As String

Dim result As String

Set dictionary = CreateObject("Scripting.Dictionary")

For i = 1 To Len(text)

char = Mid(text, i, 1)

If Not dictionary.Exists(char) Then

dictionary.Add char, Nothing

result = result & char

End If

RemoveDupeChars = result

Set dictionary = Nothing

End Function

6. Xuất dữ liệu ra PDF

Sub XuatPDF()
	'Tìm dòng cuối bảng kê
	Dim maxR As Integer
	maxR = Sheet1.Range("F" & Rows.Count).End(xlUp).Value 'Luu ý cột cần xác định ở đây là cột F

	'Xác định đường dẫn tới thư mục lưu kết quả
	Set xSht = ActiveSheet
	Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

	If xFileDlg.Show = True Then
	xFolder = xFileDlg.SelectedItems(1)
	Else
	MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
	Exit Sub
	End If

	Application.ScreenUpdating = False 'Bỏ qua việc cập nhật màn hình

	For x = 1 To maxR
	With ActiveSheet.Range("M2") '<== Vị trí ô kết quả của Spin Button
	.Value = x
	Call Spinner_getData '<== Gọi lại câu lệnh lấy dữ liệu vào PXK sau mỗi lần thay đổi kết quả Spin

	xFile = xFolder + "\" + xSht.Range("K4").Value + ".pdf" 'Xác định tên file sẽ được lưu, tên file lấy theo vị trí ô K4

	'Kiểm tra nếu tên file đã có sẵn, bị trùng tên
	If Len(Dir(xFile)) > 0 Then
	xYesorNo = MsgBox(xFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
	vbYesNo + vbQuestion, "File Exists")
	On Error Resume Next
	If xYesorNo = vbYes Then
	Kill xFile
	Else
	MsgBox "if you don't overwrite the existing PDF, I can't continue." _
	& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
	Exit Sub
	End If
	If Err.Number <> 0 Then
	MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
	& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
	Exit Sub
	End If
	End If

	Set xUsedRng = xSht.UsedRange

	If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
	'Lưu dưới định dạng file PDF
	xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFile, Quality:=xlQualityStandard
	Else
	MsgBox "The active worksheet cannot be blank" 'báo lỗi trường hợp bảng kê không có dữ liệu
	Exit Sub
	End If
	End With
	Next
	Application.ScreenUpdating = True 'mở lại chế độ cập nhật màn hình sau khi hoàn thành vòng lặp

	MsgBox "Well Done!" 'Thông báo hoàn thành công việc

	End Sub

(đang cập nhật tiếp)

Tổng hợp các code VBA cho Excel - thường dùng

Đăng nhận xét

Contact form