Bài tập về code VBA

[today100506]

[HUUDUCTRAN] CODE MẪU ! XEM & PHÁT TRIỂN ! UPDATE LIÊN TỤC

Xin chào anh chị,

Em xin lập topic này để đưa lên các code mẫu (có kèm file mẫu + code)

Mời anh chị vào xem

Nếu thấy chỗ nào chưa hay, chưa đúng, chưa hợp lý
anh chị cứ góp ý, cứ nói..., cứ sửa...thoải mái !

Em xin chân thành cảm ơn !

 

[today100506]

CODE #1 TÌM Ô CUỐI, DÒNG CUỐI, CỘT CUỐI

[COLOR=#008000]'Note: Code mo^ phong? nen chi dung sub & msgbox xem ket qua
' khong de cap nen^ dung sub/ hay function o day ![/COLOR]
Sub FindCells()
    Dim rng As Range
    Dim rslt As Range
    Dim strTmp As String
    Dim iChoice As String

    iChoice = Application.InputBox(prompt:="iChoice:", Type:=2)
    
    With Cells[COLOR=#008000] 'tim` o cuoi[/COLOR]
        Select Case iChoice
            Case 1: [COLOR=#008000]'tim` hang` cuoi'[/COLOR]
                Set rslt = .Find(what:="*", _
                                    after:=.Cells(1, 1), _
                                    LookIn:=xlFormulas, _
                                    lookat:=xlPart, _
                                    searchorder:=xlRows, _
                                    searchdirection:=xlPrevious, _
                                    MatchCase:=False)
            Case 2: [COLOR=#008000]'tim` cot^. cuoi'[/COLOR]
                Set rslt = .Find(what:="*", _
                                    after:=.Cells(1, 1), _
                                    LookIn:=xlFormulas, _
                                    lookat:=xlPart, _
                                    searchorder:=xlColumns, _
                                    searchdirection:=xlPrevious, _
                                    MatchCase:=False)
            Case 3: [COLOR=#008000]'tim` o^ cuoi'[/COLOR]
                Set rslt = .Find(what:="*", _
                                    after:=.Cells(1, 1), _
                                    LookIn:=xlFormulas, _
                                    lookat:=xlPart, _
                                    searchorder:=xlRows, _
                                    searchdirection:=xlPrevious, _
                                    MatchCase:=False)
        End Select
        If rslt Is Nothing Then: Exit Sub[COLOR=#008000] 'catch error[/COLOR]
        firstAddress = rslt.Address
        Do
            Set rslt = .FindNext(rslt)
            strtmp = rslt.Address
        Loop While rslt.Address <> firstAddress
    End With
    
    Select Case iChoice
        Case 1: MsgBox Range(strtmp).Row
        Case 2: MsgBox Range(strtmp).Column
        Case 3: MsgBox Range(strtmp).Address
    End Select
End Sub

Tham khảo thêm: http://www.giaiphapexcel.com/diendan/threads/92924.Useful-functions-Các-hàm-hữu-ích-01 (levanduyet)

 

[today100506]

CODE #2 ĐIỀN DỮ LIỆU TỪ SHEET TỔNG VÀO TỪNG SHEET CON (THEO ĐIỀU KIỆN)

Sub test()
    Dim rng As Range: Set rng = Range("a5:d209")
    Dim arr(1 To 1000, 1 To 1000)
    iRowFI = 3
    iRowIN1 = 3
    iRowIN2 = 3
    iRowPP = 3
    iRowTR12 = 3
    iRowTR34 = 3
    iRowTR56 = 3
    iRowTR78 = 3
    iRowTR910 = 3
    iRowTR1112 = 3
    
[COLOR=#008000]    'Step 1: record into array[/COLOR]
    For Each cll In rng.Columns("d").Cells
        i = i + 1
        arr(i, 1) = cll.Offset(0, -2).Value 'MaNV
        arr(i, 2) = cll.Offset(0, -1).Value 'TenNV
        arr(i, 3) = cll.Offset(0, -0).Value 'Chuyen
    Next cll
    
[COLOR=#008000]    'Step 2: write into valid sheets[/COLOR]
    On Error Resume Next
    For i = 1 To UBound(arr)
        Select Case arr(i, 3)
            Case "FI"
                On Error Resume Next
                Worksheets("FI").Cells(iRowFI, 2).Value = arr(i, 3) '3=chuyen`
                Worksheets("FI").Cells(iRowFI, 3).Value = arr(i, 1) '1=ma~
                Worksheets("FI").Cells(iRowFI, 4).Value = arr(i, 2) '2=hoten
                iRowFI = iRowFI + 5
                On Error GoTo 0
            Case "IN1"
                On Error Resume Next
                Worksheets("IN1").Cells(iRowIN1, 2).Value = arr(i, 3) '3=chuyen`
                Worksheets("IN1").Cells(iRowIN1, 3).Value = arr(i, 1) '1=ma~
                Worksheets("IN1").Cells(iRowIN1, 4).Value = arr(i, 2) '2=hoten
                iRowIN1 = iRowIN1 + 5
                On Error GoTo 0
            Case "IN2"
                On Error Resume Next
                Worksheets("IN2").Cells(iRowIN2, 2).Value = arr(i, 3) '3=chuyen`
                Worksheets("IN2").Cells(iRowIN2, 3).Value = arr(i, 1) '1=ma~
                Worksheets("IN2").Cells(iRowIN2, 4).Value = arr(i, 2) '2=hoten
                iRowIN2 = iRowIN2 + 5
                On Error GoTo 0
            Case "PP"
                On Error Resume Next
                Worksheets("PP").Cells(iRowPP, 2).Value = arr(i, 3) '3=chuyen`
                Worksheets("PP").Cells(iRowPP, 3).Value = arr(i, 1) '1=ma~
                Worksheets("PP").Cells(iRowPP, 4).Value = arr(i, 2) '2=hoten
                iRowPP = iRowPP + 5
                On Error GoTo 0
            Case "TR1,2"
                On Error Resume Next
                Worksheets("TR1,2").Cells(iRowTR12, 2).Value = arr(i, 3) '3=chuyen`
                Worksheets("TR1,2").Cells(iRowTR12, 3).Value = arr(i, 1) '1=ma~
                Worksheets("TR1,2").Cells(iRowTR12, 4).Value = arr(i, 2) '2=hoten
                iRowTR12 = iRowTR12 + 5
                On Error GoTo 0
            Case "TR3,4"
                On Error Resume Next
                Worksheets("TR3,4").Cells(iRowTR34, 2).Value = arr(i, 3) '3=chuyen`
                Worksheets("TR3,4").Cells(iRowTR34, 3).Value = arr(i, 1) '1=ma~
                Worksheets("TR3,4").Cells(iRowTR34, 4).Value = arr(i, 2) '2=hoten
                iRowTR34 = iRowTR34 + 5
                On Error GoTo 0
            Case "TR5,6"
                On Error Resume Next
                Worksheets("TR5,6").Cells(iRowTR56, 2).Value = arr(i, 3) '3=chuyen`
                Worksheets("TR5,6").Cells(iRowTR56, 3).Value = arr(i, 1) '1=ma~
                Worksheets("TR5,6").Cells(iRowTR56, 4).Value = arr(i, 2) '2=hoten
                iRowTR56 = iRowTR56 + 5
                On Error GoTo 0
            Case "TR7,8"
                On Error Resume Next
                Worksheets("TR7,8").Cells(iRowTR78, 2).Value = arr(i, 3) '3=chuyen`
                Worksheets("TR7,8").Cells(iRowTR78, 3).Value = arr(i, 1) '1=ma~
                Worksheets("TR7,8").Cells(iRowTR78, 4).Value = arr(i, 2) '2=hoten
                iRowTR78 = iRowTR78 + 5
                On Error GoTo 0
            Case "TR9,10"
                On Error Resume Next
                Worksheets("TR9,10").Cells(iRowTR910, 2).Value = arr(i, 3) '3=chuyen`
                Worksheets("TR9,10").Cells(iRowTR910, 3).Value = arr(i, 1) '1=ma~
                Worksheets("TR9,10").Cells(iRowTR910, 4).Value = arr(i, 2) '2=hoten
                iRowTR910 = iRowTR910 + 5
                On Error GoTo 0
            Case "TR11,12"
                On Error Resume Next
                Worksheets("TR11,12").Cells(iRowTR1112, 2).Value = arr(i, 3) '3=chuyen`
                Worksheets("TR11,12").Cells(iRowTR1112, 3).Value = arr(i, 1) '1=ma~
                Worksheets("TR11,12").Cells(iRowTR1112, 4).Value = arr(i, 2) '2=hoten
                iRowTR1112 = iRowTR1112 + 5
                On Error GoTo 0
        End Select
    Next i
End Sub

 

[today100506]

CODE #3 DUYỆT QUA TẤT CẢ THƯ MỤC TRONG MÁY TÍNH

[COLOR=#008000]'Note:
'Code mau^~ mo^ phong? duyet^. qua tat' ca? cac' folders trong may' tinh
'cho nen, khi binh luan, cac' ban hay tap trung vao cach viet code nhe'

[/COLOR][COLOR=#0000ff]Sub[/COLOR] main()
    Call browseFoldersAZ
End Sub

[COLOR=#0000ff]Sub[/COLOR] browseFoldersAZ()
    Dim fso, drv, pathTextFile As Object
    Set fso = New Scripting.FileSystemObject
    Set drvs = fso.Drives
    Set pathTextFile = fso.CreateTextFile("C:\text.txt", overwrite:=True)
        pathTextFile.Close
    
    On Error Resume Next 'catch error
    
    For Each drv In drvs 'browse drives
        browseFolder (drv.RootFolder)
    Next drv
    
    Set pathTextFile = Nothing 'erase
    Set drv = Nothing
    Set fso = Nothing
End Sub

[COLOR=#0000ff]Sub [/COLOR]browseFolder(specFdr) 'browse folders
    Dim fso, fdr, sfdr As Object
    Set fso = New Scripting.FileSystemObject
    Set fdr = fso.GetFolder(specFdr)
    Set sfdr = fdr.SubFolders
        
    For Each fdr In sfdr
        Set pathTextFile = fso.OpenTextFile("C:\text.txt", IOMode:=ForAppending)
            pathTextFile.WriteLine (fdr.Path)
            pathTextFile.Close
        MsgBox fdr.Path
        browseFolder (fdr.Path)
    Next fdr
    
    Set sfdr = Nothing
    Set fdr = Nothing
    Set fso = Nothing
    
End Sub

 

[today100506]

[VBA] CODE #4 TỔNG HỢP CÁC CÁCH TÁCH HỌ VÀ TÊN BẰNG VBA
tham khảo thêm tại: http://www.giaiphapexcel.com/diendan/threads/92923.Tổng-hợp-các-phương-pháp-tách-họ-và-tên

PHẦN 1: TÁCH HỌ

[COLOR=#008000]'XU LY CHUOI
'way 1: Su dung vong lap
'way 2: Su dung cac ham xu ly chuoi san co cua VBA
'way 3: Su dung cac ham xu ly chuoi san co cua WorksheetFunction
'
'NOTE:
'way3 con vuong mot vai cho chua xu ly duoc:
'     + xu ly nhu the nao voi cong thuc mang {Ctrl + Shift + Enter}
'     + chua giai quyet duoc cho^~ chua' cong thuc mang~ ROW($1:$50)trong cong thuc sau: _
'             Mid(Trim(strName),ROW($1:$50),1)=" " ...[/COLOR]

[COLOR=#008000]'XU LY CHUOI - FIRST PART - GROUP
[/COLOR]Sub test()
    Dim strName1, strName2, strName3, strName4, strChoice As String
    strName1 = "Linh"
    strName2 = "Thach Linh"
    strName3 = "Thach Thi Linh"
    strName4 = "Thach Thi Thao Linh"
    
    strChoice = "1"
    Call xulychuoi_dau1(strName4, strChoice)
    Call xulychuoi_dau1(strName3, strChoice)
    Call xulychuoi_dau1(strName2, strChoice)
    Call xulychuoi_dau1(strName1, strChoice)
End Sub

Function xulychuoi_dau1(ByVal strName As String, Optional ByVal choice As String = "1") As String
    Dim strTmp As String
    Dim length As Integer
    Dim wsf As WorksheetFunction
    
    Select Case choice
        Case "1": [COLOR=#008000]'way 1: Su dung vong lap[/COLOR]
            For i = 1 To Len(Trim(strName)) Step 1
                If mid(Trim(strName), i, 1) = " " Then: Exit For
                strTmp = strTmp & mid(Trim(strName), i, 1)
            Next i
        
        Case "2": [COLOR=#008000]'way 2: Su dung cac ham xu ly chuoi san co cua VBA[/COLOR]
            length = InStr(1, Trim(strName), " ", vbtextcomapre) - 1
            Select Case length
                Case -1: strTmp = strName
                Case Else: strTmp = Left(Trim(strName), length)
            End Select
        
        Case "3a" [COLOR=#008000]'way 3a: Su dung cac ham xu ly chuoi san co cua WorksheetFunction - left n ky tu[/COLOR]
            Set wsf = Application.WorksheetFunction
            On Error Resume Next
            length = wsf.Find(" ", Trim(strName), 1) - 1
            Select Case Err.Number
                Case 0: strTmp = Left(Trim(strName), length)
                Case 1004: strTmp = strName
                Case Else: strTmp = -9999 'new error code #
            End Select
            On Error GoTo 0

        Case "3b" [COLOR=#008000]'way 3b: Su dung cac ham xu ly chuoi san co cua WorksheetFunction - replace 'X'kytu -> ""[/COLOR]
            Dim intPosition As Integer
            Set wsf = Application.WorksheetFunction
            length = 50
            On Error Resume Next
            intPosition = wsf.Find(" ", Trim(strName), 1)
            Select Case Err.Number
                Case 0: strTmp = wsf.Replace(Trim(strName), intPosition, length, "")
                Case 1004: strTmp = strName
                Case Else: strTmp = -9999 'new error code #
            End Select
            On Error GoTo 0
        
        Case "3c" [COLOR=#008000]'way 3c: Su dung cac ham xu ly chuoi san co cua WorksheetFunction - Substitute ky tu 'X' -> "         [/COLOR]    "
            Set wsf = Application.WorksheetFunction
            strTmp = Trim(Left(wsf.Substitute(Trim(strName), " ", "                    "), 20))
        Case Else:
            strTmp = ""
    End Select
    
    xulychuoi_dau1 = strTmp
    
    MsgBox xulychuoi_dau1 & vbTab & Len(xulychuoi_dau1)

End Function

PHẦN II: TÁCH TÊN

Sub test()
    Dim strName1, strName2, strName3, strName4, strChoice As String
    strName1 = "Linh"
    strName2 = "Thach Linh"
    strName3 = "Thach Thi Linh"
    strName4 = "Thach Thi Thao Linh"
    
    strChoice = "1"
    Call xulychuoi_cuoi1(strName4, strChoice)
    Call xulychuoi_cuoi1(strName3, strChoice)
    Call xulychuoi_cuoi1(strName2, strChoice)
    Call xulychuoi_cuoi1(strName1, strChoice)
End Sub

Function xulychuoi_cuoi1(ByVal strName As String, Optional ByVal choice As String) As String
    Dim strTmp As String
    Dim length As Integer
    
    Select Case choice
        Case "1" [COLOR=#008000]'way 1: Su dung vong lap[/COLOR]
            For i = Len(Trim(strName)) To 1 Step -1
                If mid(Trim(strName), i, 1) = " " Then: Exit For
                strTmp = mid(Trim(strName), i, 1) & strTmp
            Next i

        Case "2" [COLOR=#008000]'way 2: Su dung cac ham xu ly chuoi san co cua VBA[/COLOR]
            length = InStrRev(Trim(strName), " ", -1, vbTextCompare)
            strTmp = Right(Trim(strName), Len(Trim(strName)) - length)
        
        Case "3" [COLOR=#008000]'way 3: Su dung cac ham xu ly chuoi san co cua WorksheetFunction[/COLOR]
                    ' chua du kha nang xu ly...

        Case Else: strTmp = ""
    End Select
    
    xulychuoi_cuoi1 = strTmp
    
    MsgBox xulychuoi_cuoi1 & vbTab & Len(xulychuoi_cuoi1)

End Function

PHẦN III: TÁCH CHỮ LÓT

Sub test()
    Dim strName1, strName2, strName3, strName4, strChoice As String
    strName1 = "Linh"
    strName2 = "Thach Linh"
    strName3 = "Thach Thi Linh"
    strName4 = "Thach Thi Thao Linh"
        
    strChoice = "1"
    Call xulychuoi_cuoi1(strName4, strChoice)
    Call xulychuoi_cuoi1(strName3, strChoice)
    Call xulychuoi_cuoi1(strName2, strChoice)
    Call xulychuoi_cuoi1(strName1, strChoice)
End Sub

Function xulychuoi_cuoi1(ByVal strName As String, Optional ByVal choice As String = "1") As String
    Dim strTmp As String
    Dim intStart, intEnd, length As Integer
        
    Select Case choice
        Case "1" [COLOR=#008000]'way 1: Su dung vong lap[/COLOR]
            For i = 1 To Len(Trim(strName)) Step 1
                If mid(Trim(strName), i, 1) = " " Then: intStart = i + 1: Exit For
            Next i
            For i = Len(Trim(strName)) To 1 Step -1
                If mid(Trim(strName), i, 1) = " " Then: intEnd = i - 1: Exit For
            Next i
            GoTo lxulychung:
            
        Case "2" [COLOR=#008000]'way 2: Su dung cac ham xu ly chuoi san co cua VBA[/COLOR]
            intStart = InStr(1, Trim(strName), " ", vbTextCompare) + 1
            intEnd = InStrRev(Trim(strName), " ", -1, vbTextCompare) - 1
            GoTo lxulychung:
            
        Case "3" [COLOR=#008000]'way 3: Su dung cac ham xu ly chuoi san co cua WorksheetFunction
                    ' chua du kha nang xu ly...[/COLOR]
        
        Case Else: strTmp = ""
    End Select
    
[COLOR=#0000ff]lxulychung:[/COLOR]
    Select Case intStart 'just intStart is enough
        Case 0: strTmp = "" 'one word
        Case Is > intEnd: strTmp = "" 'two word
        Case Else
            Select Case choice
                Case "1"
                    For i = intStart To intEnd Step 1 'catched error below !
                        strTmp = strTmp & mid(Trim(strName), i, 1)
                    Next i
                Case "2"
                    length = (intEnd - intStart) + 1
                    strTmp = mid(Trim(strName), intStart, length) 'catched error below !
            End Select
    End Select

        
    xulychuoi_cuoi1 = strTmp
    MsgBox xulychuoi_cuoi1 & vbTab & Len(xulychuoi_cuoi1)
End Function

 

[SA_DQ]

Như tiêu đề topic bạn nêu là Code mẫu;

Vậy thì trong fần tách họ trong chuỗi họ tên ta nên đưa thêm hàm tách họ dựa vô hàm Intr() thay thế cho vòng lặp hiện hữu của bạn.

Như :

VTr = InStr( HoTen," ")
TachHo= Let(HoTen, VTr - 1)

Chúc bạn nhiều thành công hơn nữa!

 

[today100506]

Như tiêu đề topic bạn nêu là Code mẫu;

Vậy thì trong fần tách họ trong chuỗi họ tên ta nên đưa thêm hàm tách họ dựa vô hàm Intr() thay thế cho vòng lặp hiện hữu của bạn.

Như :

VTr = InStr( HoTen," ")
TachHo= Let(HoTen, VTr - 1)

Chúc bạn nhiều thành công hơn nữa!

Chắc chắn, InStr là hàm tiếp theo mình sẽ nghiên cứu đến...
Do hiện tại, mình chưa biết sử dụng hàm InStr nên trong code mẫu chưa có, heheh,
Thanks bạn !
...
......
.........
Bây giờ là, 1:38 PM 5/5/2014, theo góp ý của bạn HYen17, mình đã update code mới, xin mời các bạn xem qua !

 

[ChanhTQ@]

Là mình thì bài #3 mình sẽ viết vầy:

Option Base 1:                              Option Explicit
Sub ChamCong()
 Dim Arr():                                 Dim J4 As Long, J5 As Long, J6 As Long
 Dim Rws As Long, J As Long, VTr As Byte, J1 As Long, J2 As Long, J3 As Long
 Const ShN As String = "FI  IN1 IN2 TR12TR34TR56"
 
 Rws = [B5].CurrentRegion.Rows.Count
 Arr = [B5].Resize(Rws, 3).Value
 ReDim aFI(Rws, 3):                         ReDim aIN1(Rws, 3)
 ReDim aT12(Rws, 3):                        ReDim aIN2(Rws, 3)
 ReDim aT34(Rws, 3):                        ReDim aT56(Rws, 3)
 J1 = 1:            J2 = 1:                 J3 = 1
 J4 = 1:            J5 = 1:                 J6 = 1
 For J = 1 To UBound(Arr())
    VTr = InStr(ShN, Arr(J, 3))
    Select Case VTr
    Case 1
        aFI(J1, 1) = Arr(J, 3)
        aFI(J1, 2) = Arr(J, 1):             aFI(J1, 3) = Arr(J, 2)
        J1 = 5 + J1
    Case 5
        aIN1(J2, 1) = Arr(J, 3)
        aIN1(J2, 2) = Arr(J, 1):            aIN1(J2, 3) = Arr(J, 2)
        J2 = 5 + J2
    Case 9
        aIN2(J3, 1) = Arr(J, 3)
        aIN2(J3, 2) = Arr(J, 1):            aIN2(J3, 3) = Arr(J, 2)
        J3 = 5 + J3
    Case 13
        aT12(J4, 1) = Arr(J, 3)
        aT12(J4, 2) = Arr(J, 1):            aT12(J4, 3) = Arr(J, 2)
        J4 = 5 + J4
    Case 17
        aT34(J5, 1) = Arr(J, 3)
        aT34(J5, 2) = Arr(J, 1):         aT34(J5, 3) = Arr(J, 2)
        J5 = 5 + J5
    Case 21
        aT56(J6, 1) = Arr(J, 3)
        aT56(J6, 2) = Arr(J, 1):         aT56(J6, 3) = Arr(J, 2)
        J6 = 5 + J6
    End Select
 Next J
 Sheets("FI").[b3].Resize(Rws, 3) = aFI()
 Sheets("IN1").[b3].Resize(Rws, 3) = aIN1()
 Sheets("IN2").[b3].Resize(Rws, 3) = aIN2()
 Sheets("TR12").[b3].Resize(Rws, 3) = aT12()
 Sheets("TR34").[b3].Resize(Rws, 3) = aT34()
 Sheets("TR56").[b3].Resize(Rws, 3) = aT56()
 
End Sub

(3 trang tính sau mình đã đổi tên)

 

[sealand]

Em thấy Bác ChanhTQ@ cũng vẫn còn dài. Em thấy nếu chỉ chép (Vì chưa có đoạn xoá DL cũ) thì như sau cũng ổn:

Sub STest()
Dim Tmp, i, j
Const StrName = "FI;TR1,2;IN1,IN2;TR5,6;TR3,4"
Tmp = Sheet1.Range("A5:D" & Sheet1.[A65536].End(3).Row)
For i = 1 To UBound(Tmp, 1)
If InStr(1, StrName, Tmp(i, 4)) > 0 Then
With ThisWorkbook.Worksheets(Tmp(i, 4))
For j = 3 To 65000 Step 5
If .Cells(j, 1) = "" Then
.Cells(j, 1) = Int(j / 5) + 1
.Cells(j, 2) = Tmp(i, 4)
.Cells(j, 3) = Tmp(i, 2)
.Cells(j, 4) = Tmp(i, 3)
Exit For
End If
Next j
End With
End If
Next i
End Sub

 

[today100506]

[VBA] CODE #5 TỔNG HỢP CÁC CÁCH KIỂM TRA FILE CÓ TỔN TẠI ?
VỚI KHẢ NĂNG HIỆN TẠI, MÌNH CHỈ LÀM ĐƯỢC NHƯ NÀY.
SAU NÀY MÌNH SẼ BỔ SUNG THÊM...!

Sub test()
Dim strFilename, strChoice As String
strFilename = "C:\test\test.xlsx"

strChoice = "1"
MsgBox func_isFileExists(strFilename, strChoice)
End Sub

Function func_isFileExists(ByVal strFilename As String, Optional ByVal strChoice As String = "1") As Boolean
    Dim intErrNum As Integer
    Dim objFile As file
    Dim objFSO As FileSystemObject
    
    On Error Resume Next [COLOR=#008000]'catch error[/COLOR]
        Select Case strChoice
            Case "1" [COLOR=#008000]'way 1: open/ close --> get err.number[/COLOR]
                    Open strFilename For Input Lock Read As #1
                    Close 1
                    intErrNum = Err.Number
            Case "2" [COLOR=#008000]'way 2: getFile (fso) --> get err.number
[/COLOR]                Set objFSO = CreateObject("scripting.filesystemobject")
                Set objFile = objFSO.GetFile(strFilename)
                intErrNum = Err.Number
            Case Else: 'default ("1")
                Open strFilename For Input Lock Read As #1
                Close 1
                intErrNum = Err.Number
        End Select
    On Error GoTo 0
    
    Select Case intErrNum
        Case 0: func_isFileExists = True [COLOR=#008000]'file exists[/COLOR]
        Case 55: func_isFileExists = True [COLOR=#008000]'file already open[/COLOR]
        Case 70: func_isFileExists = True [COLOR=#008000]'permission denied[/COLOR]
        Case 53: func_isFileExists = False [COLOR=#008000]'file not found[/COLOR]
        Case Else: func_isFileExists = -9999 [COLOR=#008000]'new error code #[/COLOR]
    End Select
    
    Set objFile = Nothing
    Set objFSO = Nothing
End Function

 

[today100506]

[VBA] CODE #6 TỔNG HỢP CÁC CÁCH KIỂM TRA FILE ĐANG MỞ (isFileOpenning)

VỚI KHẢ NĂNG HIỆN TẠI, MÌNH CHỈ LÀM ĐƯỢC NHƯ NÀY.
SAU NÀY MÌNH SẼ BỔ SUNG THÊM...!


Code thứ 1: Có thể check mọi loại file (isFileOpenning)

[COLOR=#008000]'way to process this problem:
'step 1: check it exists (isFileExists)
'step 2: if exists, continuous... check it openning (func_isFileOpenning)
'
'*Note:
'Khi check thuc te thi gap phai van de nhu the nay:
'     step 1: Minh tu?. mo? san file "C:\test\test.xlsx"
'     step 2: check func_isFileOpenning, thi no' ko hieu la file da~ open ???
'        Open strFilename For Input Lock Read As #intFilenum
' co' phai la do khi minh tu?. mo? file, va khi chay lenh no' mo? file, _
' so #intFileNum khac nhau, nen no' ko hieu ???
[/COLOR]
Sub test()
Dim strFilename, strChoice As String
strFilename = "C:\test\test.xlsx"

strChoice = "1"
MsgBox func_isFileOpenning(strFilename, strChoice)
End Sub

[COLOR=#008000]'(2) func_isFileOpenning ?
[/COLOR]Function func_isFileOpenning(ByVal strFilename As String, Optional ByVal strChoice As String) As Boolean
    Dim intErrNum, intFilenum As Integer
    intFilenum = FreeFile()
    
    If Not func_isFileExists(strFilename, strChoice) Then: MsgBox "File not exists !": Exit Function
    
    On Error Resume Next 'catch error
        Open strFilename For Input Lock Read As [COLOR=#0000ff]#intFilenum[/COLOR]
        Close intFilenum
        intErrNum = Err.Number
    On Error GoTo 0
    
    Select Case intErrNum
        Case 55: func_isFileOpenning = True [COLOR=#008000]'file already open
[/COLOR]        Case Else: func_isFileOpenning = False
    End Select
End Function

[COLOR=#008000]'(1) isFileExists ?
[/COLOR]Function func_isFileExists(ByVal strFilename As String, Optional ByVal strChoice As String = "1") As Boolean
    Dim intErrNum, intFilenum As Integer
    Dim objFile As file
    Dim objFSO As FileSystemObject
    intFilenum = FreeFile()
    
    On Error Resume Next 'catch error
        Select Case strChoice
            Case "1" 'way 1: open/ close --> get err.number
                    Open strFilename For Input Lock Read As #intFilenum
                    Close intFilenum
                    intErrNum = Err.Number
            Case "2" 'way 2: getFile (fso) --> get err.number
                Set objFSO = CreateObject("scripting.filesystemobject")
                Set objFile = objFSO.GetFile(strFilename)
                intErrNum = Err.Number
            Case Else: 'default ("1")
                Open strFilename For Input Lock Read As #intFilenum
                Close intFilenum
                intErrNum = Err.Number
        End Select
    On Error GoTo 0
    
    Select Case intErrNum
        Case 0: func_isFileExists = True 'file exists
        Case 55: func_isFileExists = True 'file already open
        Case 70: func_isFileExists = True 'permission denied
        Case 53: func_isFileExists = False 'file not found
        Case Else: func_isFileExists = -9999 'new error code #
    End Select
    
    Set objFile = Nothing
    Set objFSO = Nothing
End Function

Code thứ 2: Dành check riêng cho file excel (isXlFileOpenning)
Cách này, lúc em chập chững lộm cộm VBA, pác ndu96081631 hướng dẫn cho em...!

[COLOR=#008000]'way to process this problem:
'very easy...
'Trong truong hop nay, ta giai quyet nhu sau:
'chi can biet' file excel do' co mo~ len hay chua
'khong can biet' no' co ton^` tai hay khong^(isFileExists?)

[/COLOR]Sub test()
Dim strFilename As String
strFilename = "C:\test\test.xlsx"

MsgBox func_isXlFileOpenning(strFilename)
End Sub

Function func_isXlFileOpenning(ByVal strFilename As String) As Boolean
    Dim intLength As Integer
    Dim strName As String
        
[COLOR=#008000]    'process string: get name[/COLOR]
    intLength = Len(Trim(strFilename)) - InStrRev(Trim(strFilename), "\", -1, vbTextCompare)
    strName = Right(Trim(strFilename), intLength)

    On Error Resume Next [COLOR=#008000]'catch error[/COLOR]
        func_isXlFileOpenning =[COLOR=#0000ff] CBool(Len(Workbooks(strName).name))[/COLOR]
    On Error GoTo 0
End Function

 

[ndu96081631]

Bạn nói rằng:

VỚI KHẢ NĂNG HIỆN TẠI, MÌNH CHỈ LÀM ĐƯỢC NHƯ NÀY.
SAU NÀY MÌNH SẼ BỔ SUNG THÊM...!

Vậy thì sao gọi là code mẫu GPE được nhỉ?
Mẫu là chuẩn mực để mọi người học hỏi. Vậy nên tôi nghĩ topic này chỉ nên xem là nơi để góp ý và hoàn thiện những gì bạn đã làm được mà thôi
(Nói chung, gọi là MẪU thì hơi quá)

 

[today100506]

Bạn nói rằng:


Vậy thì sau gọi là code mẫu GPE được nhỉ?
Mẫu là chuẩn mực để mọi người học hỏi. Vậy nên tôi nghĩ topic này chỉ nên xem là nơi để góp ý và hoàn thiện những gì bạn đã làm được mà thôi
(Nói chung, gọi là MẪU thì hơi quá)

Em xin chào pác ndu96081631,

Thật ra, cái tên topic đầu tiên em đặt là:

[HUUDUCTRAN] CODE MẪU ! XEM & PHÁT TRIỂN ! UPDATE LIÊN TỤC

Nhưng em không biết thành viên nào trong BQT đã sửa lại cho em cái tên mới này,

uhm thì sửa..., em cũng xin vâng !

Một lần nữa, cảm ơn pác ndu đã quan tâm đến topic này !

Trân Trọng & kính chào !

 

[ndu96081631]

Em xin chào pác ndu96081631,

Thật ra, cái tên topic đầu tiên em đặt là:

[HUUDUCTRAN] CODE MẪU ! XEM & PHÁT TRIỂN ! UPDATE LIÊN TỤC

Nhưng em không biết thành viên nào trong BQT đã sửa lại cho em cái tên mới này,

uhm thì sửa..., em cũng xin vâng !

Một lần nữa, cảm ơn pác ndu đã quan tâm đến topic này !

Trân Trọng & kính chào !

Thật ra cũng chỉ góp ý thế thôi (theo ý kiến cá nhân tôi) chứ sửa hoặc không sửa cũng là quyền của bạn. Vả lại, bạn cũng không thể tự sửa tiêu đề (chỉ có BQT mới làm được)
Mà nếu phải sửa lại tiêu đề thì tôi cũng chẳng biết phải sửa thế nào cho đúng
???

 

[ptm0412]

Em xin chào pác ndu96081631,
Thật ra, cái tên topic đầu tiên em đặt là:

[HUUDUCTRAN] CODE MẪU ! XEM & PHÁT TRIỂN ! UPDATE LIÊN TỤC

Nhưng em không biết thành viên nào trong BQT đã sửa lại cho em cái tên mới này,

Cái tiêu đề ban đầu của bạn "kêu" quá, nếu không nói là câu view, nên tôi sửa. Tôi sửa 1 lúc cả 3 topic "kêu" đùng đùng như vậy.

Còn topic này: Trong vài bài đầu, tôi thấy bạn có để link đến các bài viết có sẵn, cụ thể là bài của LevanDuyet và hoangdanh282, nên nghĩ đó là code mẫu cũa GPE thật, vì Code của LevanDuyet và hoangdanh282 xứng đáng gọi là code mẫu.

Những bài sau đó bạn đưa code của bạn lên, vậy thì không còn là code mẫu nữa. Giờ tôi biết sửa sao đây?

 

[SA_DQ]

[thongbao] Giờ thì không còn là code mẫu nữa. [/thongbao]

Thì sửa lại là những mẫu code! /(hà, Khà, khà,. . . . Cần fát triển liên tục

 

[VetMini]

Ý của bạn muốn học hỏi thì đưa 1 bài code lên rồi nhờ người ta góp ý. Ít nhất cũng một mớ sửa đổi rồi mới sang bài khác.

Bạn đưa liên tiếp một đống tả pí lù. Cái thì tự viết, cái cóp ở đâu dó. Chả có trật tự, chả có phạm vi tiêu đề gì cả.
Rốt cuộc lại thì người muốn phê bình cũng ngán mà người muốn học hỏi cũng loạn óc hết.

Tôi nghĩ có thể chính bạn cũng chả biết code mẫu dùng để làm gì.
Trả lời gợi ý: người học code lập ra một đống file codeABC.bas (file text). Mỗi file là một module có tên liên hệ tới phạm vi công việc. Một khi code đã được cho là "tốt" rồi thì người ta chọn đúng file, nhét nó vào để dành. Cái đó dân trong nghề gọi là thư viện code hay code mẫu. Khi cần vào một vấn đề gì đó, người ta lôi đám thư viện này ra, xem cái nào đúng thì import vào project của mình. Nếu không có thì tìm cái gần nhất và sửa.
Đó là lý do tại sao khi viết code người ta luôn luôn ghi chú. Bởi vì không có ghi chú thì nửa năm sau, đọc lại code chả hiểu nó làm cái gì.

 

[siwtom]

Cái tiêu đề ban đầu của bạn "kêu" quá, nếu không nói là câu view, nên tôi sửa. Tôi sửa 1 lúc cả 3 topic "kêu" đùng đùng như vậy.

Còn topic này: Trong vài bài đầu, tôi thấy bạn có để link đến các bài viết có sẵn, cụ thể là bài của LevanDuyet và hoangdanh282, nên nghĩ đó là code mẫu cũa GPE thật, vì Code của LevanDuyet và hoangdanh282 xứng đáng gọi là code mẫu.

Những bài sau đó bạn đưa code của bạn lên, vậy thì không còn là code mẫu nữa. Giờ tôi biết sửa sao đây?

Thì sửa thành "Code gửi phụ mẫu GPE" thôi

 

[today100506]

Cái tiêu đề ban đầu của bạn "kêu" quá, nếu không nói là câu view, nên tôi sửa. Tôi sửa 1 lúc cả 3 topic "kêu" đùng đùng như vậy.

Còn topic này: Trong vài bài đầu, tôi thấy bạn có để link đến các bài viết có sẵn, cụ thể là bài của LevanDuyet và hoangdanh282, nên nghĩ đó là code mẫu cũa GPE thật, vì Code của LevanDuyet và hoangdanh282 xứng đáng gọi là code mẫu.

Những bài sau đó bạn đưa code của bạn lên, vậy thì không còn là code mẫu nữa. Giờ tôi biết sửa sao đây?

Em xin cảm ơn BQT & các member lão thành đã góp ý, quan tâm đến các bài viết của em.

Em xin có ý kiến một tý về phát ngôn sau của thầy ptm0412 (chỉ là suy nghĩ, em ko có ý gì khác đâu nhé thầy ptm)

Cái tiêu đề ban đầu của bạn "kêu" quá, nếu không nói là câu view...

Thật ra, lúc em đặt tên, em chỉ nghĩ đơn giản thế này:
1. Cái em đưa lên là code --> nên em gọi đó là code mẫu !
2. Em cho đi tất cả, em đưa lên vừa để cho mọi người xem & vừa học hỏi thêm nếu có ai góp ý --> nên em đặt tiếp là "Xem & Phát triển !
3. Bài topic luôn được em up code lên thường xuyên --> nên em để thêm vô là "Update liên tục"

Cho nên, từ (1), (2) và (3) ==>> cái tên em đặt cho topic nó có dáng vẻ như thế này:

"Code mẫu ! Xem & Phát triển ! Update liên tục !

Ý của em chỉ là đặt một cái tên đơn giản và thực tế, chứ em đâu có cần câu view câu viết làm gì...

Có thể thầy ptm0412 đã hiểu lầm em...Nhưng thành thật, em xin cảm ơn thầy vì thầy đã quan tâm đến topic ! Thật sự !

Cái ngày mà em hỏi pác ndu các viết code vba "kiểm tra file có tồn tại" là cái ngày em bắt đầu học VBA,
Từ ngày em chập chững viết code đến giờ, chắc cũng mười mươi bữa rồi,
Mong được thầy ptm0412 và các anh chị chỉ bảo tận tình trong con đường sắp tới của em...

Trân trọng & Kính chào !

 

[today100506]

[VBA] CODE #7 HÀM TỰ TẠO - fTrim (HOẠT ĐỘNG NHƯ TRIM)

[SIZE=3]Function fTrim(ByVal str As String) As String
    Dim i, iStart, iEnd, iLength As Integer
    
    i = 1 [COLOR=#008000]'get start position[/COLOR]
    Do Until mid(str, i, 1) <> " "
        i = i + 1
    Loop
    iStart = i
    
    If iStart > Len(str) Then: Exit Function [COLOR=#008000]'catch error: string only {spacebar} character[/COLOR]
    
    i = Len(str) [COLOR=#008000]'get end position[/COLOR]
    Do Until mid(str, i, 1) <> " "
        i = i - 1
    Loop
    iEnd = i
        
    iLength = iEnd - iStart + 1
    [COLOR=#0000ff]fTrim = mid(str, iStart, iLength)
[/COLOR]End Function[/SIZE][B][SIZE=3]
[/SIZE][/B]