Nhờ rút gọn code để di chuyển file dùng FileSystemObject (FSO) (1 người xem)

Elx Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
H

hoi_joker84

Thành viên mới
Tham gia
18/12/08
Bài viết
16
Được thích
14
Nghề nghiệp
Agent
Nhờ rút gọn Code!

Mình có đoạn code kiểm tra điều kiện để di chuyển file = FileSystemObject như dưới. Có phương án nào rút gọn được không? hoặc tối ưu hơn không?

Xin Cảm ơn

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("$H$31:$H$33")) Is Nothing Then
        Dim oFile As Object, FSO As Object, sDesPath As String, sSourcePath As String, arrFiles, i As Long
        sDesPath = ThisWorkbook.Path
        sSourcePath = sDesPath & "\#\Docs"
        Set FSO = CreateObject("Scripting.FileSystemObject")
                arrFiles = Array("HosoA.doc", _
                                        "HosoB.doc", _
                                        "HosoC.doc", _
                                        "HosoD.doc", _
                                        "HosoTest.doc", _
                                        "ABC.doc", _
                                        "BL.jpg", _
                                        "Formalities.xls", _
                                        "KHAI BAO.xls", _
                                        "RRR.doc", _
                                        "Template.xls")
           
    If UCase(Trim([H31])) = "DIA DIEM 1" Or UCase(Trim([H31])) = "DIA DIEM 2" Then
        If UCase(Trim([H32])) = "DIEU KIEN 1" Then
            For i = 1 To 11
                If i = 3 Or i = 4 Or i = 5 Or i = 6 Or i = 7 Then
                    If FSO.FileExists(sSourcePath & "\" & arrFiles(i)) Then FSO.movefile sSourcePath & "\" & arrFiles(i), sDesPath & "\" & arrFiles(i)
                Else
                    If FSO.FileExists(sDesPath & "\" & arrFiles(i)) Then FSO.movefile sDesPath & "\" & arrFiles(i), sSourcePath & "\" & arrFiles(i)
                End If
            Next i
        Else
            For i = 1 To 11
                 If i = 10 Then
                    If FSO.FileExists(sSourcePath & "\" & arrFiles(i)) Then FSO.movefile sSourcePath & "\" & arrFiles(i), sDesPath & "\" & arrFiles(i)
                Else
                    If FSO.FileExists(sDesPath & "\" & arrFiles(i)) Then FSO.movefile sDesPath & "\" & arrFiles(i), sSourcePath & "\" & arrFiles(i)
                End If
            Next i
        End If
    Else            'DIA DIEM 3
        If UCase(Trim([H32])) = "DIEU KIEN 1" Then
            For i = 1 To 11
                If i = 1 Or i = 3 Or i = 4 Or i = 5 Or i = 6 Or i = 7 Or i = 8 Or i = 9 Or i = 11 Then
                    If FSO.FileExists(sSourcePath & "\" & arrFiles(i)) Then FSO.movefile sSourcePath & "\" & arrFiles(i), sDesPath & "\" & arrFiles(i)
                Else
                    If FSO.FileExists(sDesPath & "\" & arrFiles(i)) Then FSO.movefile sDesPath & "\" & arrFiles(i), sSourcePath & "\" & arrFiles(i)
                End If
            Next i
        Else
            For i = 1 To 11
                 If i = 2 Or i = 10 Then
                    If FSO.FileExists(sSourcePath & "\" & arrFiles(i)) Then FSO.movefile sSourcePath & "\" & arrFiles(i), sDesPath & "\" & arrFiles(i)
                Else
                    If FSO.FileExists(sDesPath & "\" & arrFiles(i)) Then FSO.movefile sDesPath & "\" & arrFiles(i), sSourcePath & "\" & arrFiles(i)
                End If
            Next i
        End If
    End If
        Set oFile = Nothing
        Set FSO = Nothing
    End If
End Sub
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Mục đích chỉ để gọn hơn chứ không chắc hay hơn nha:
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("$H$31:$H$33")) Is Nothing Then
        Dim oFile As Object, Fso As Object, sDesPath As String, sSourcePath As String, arrFiles, i As Long
        sDesPath = ThisWorkbook.Path
        sSourcePath = sDesPath & "\#\Docs"
        Set Fso = CreateObject("Scripting.FileSystemObject")
                arrFiles = Array("HosoA.doc", _
                                        "HosoB.doc", _
                                        "HosoC.doc", _
                                        "HosoD.doc", _
                                        "HosoTest.doc", _
                                        "ABC.doc", _
                                        "BL.jpg", _
                                        "Formalities.xls", _
                                        "KHAI BAO.xls", _
                                        "RRR.doc", _
                                        "Template.xls")
    On Error Resume Next
    If InStr(1, "DIA DIEM 1,DIA DIEM 2", UCase(Trim([H31]))) > 0 Then
        If UCase(Trim([H32])) = "DIEU KIEN 1" Then
            For i = 1 To 11
                If Choose(i, 0, 0, 1, 1, 1, 1, 1, 0, 0, 0, 0) = 1 Then
                Fso.movefile sSourcePath & "\" & arrFiles(i), sDesPath & "\" & arrFiles(i)
                Else
                Fso.movefile sDesPath & "\" & arrFiles(i), sSourcePath & "\" & arrFiles(i)
                End If
            Next i
        Else
            For i = 1 To 11
                 If i = 10 Then
                    Fso.movefile sSourcePath & "\" & arrFiles(i), sDesPath & "\" & arrFiles(i)
                Else
                    Fso.movefile sDesPath & "\" & arrFiles(i), sSourcePath & "\" & arrFiles(i)
                End If
            Next i
        End If
    Else            'DIA DIEM 3
        If UCase(Trim([H32])) = "DIEU KIEN 1" Then
            For i = 1 To 11
                If Choose(i, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1) = 1 Then
                    Fso.movefile sSourcePath & "\" & arrFiles(i), sDesPath & "\" & arrFiles(i)
                Else
                    Fso.movefile sDesPath & "\" & arrFiles(i), sSourcePath & "\" & arrFiles(i)
                End If
            Next i
        Else
            For i = 1 To 11
                 If i = 2 Or i = 10 Then
                    Fso.movefile sSourcePath & "\" & arrFiles(i), sDesPath & "\" & arrFiles(i)
                Else
                    Fso.movefile sDesPath & "\" & arrFiles(i), sSourcePath & "\" & arrFiles(i)
                End If
            Next i
        End If
    End If
        Set oFile = Nothing
        Set Fso = Nothing
    End If
End Sub

Thực ra, cái này dùng Dir và ChDir v.v... nhanh gọn hơn nhiều vì nó là con đẻ.
 
Upvote 0
sealand đã viết:
Mục đích chỉ để gọn hơn chứ không chắc hay hơn nha:
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("$H$31:$H$33")) Is Nothing Then
        Dim oFile As Object, Fso As Object, sDesPath As String, sSourcePath As String, arrFiles, i As Long
        sDesPath = ThisWorkbook.Path
        sSourcePath = sDesPath & "\#\Docs"
        Set Fso = CreateObject("Scripting.FileSystemObject")
                arrFiles = Array("HosoA.doc", _
                                        "HosoB.doc", _
                                        "HosoC.doc", _
                                        "HosoD.doc", _
                                        "HosoTest.doc", _
                                        "ABC.doc", _
                                        "BL.jpg", _
                                        "Formalities.xls", _
                                        "KHAI BAO.xls", _
                                        "RRR.doc", _
                                        "Template.xls")
    On Error Resume Next
    If InStr(1, "DIA DIEM 1,DIA DIEM 2", UCase(Trim([H31]))) > 0 Then
        If UCase(Trim([H32])) = "DIEU KIEN 1" Then
            For i = 1 To 11
                If Choose(i, 0, 0, 1, 1, 1, 1, 1, 0, 0, 0, 0) = 1 Then
                Fso.movefile sSourcePath & "\" & arrFiles(i), sDesPath & "\" & arrFiles(i)
                Else
                Fso.movefile sDesPath & "\" & arrFiles(i), sSourcePath & "\" & arrFiles(i)
                End If
            Next i
        Else
            For i = 1 To 11
                 If i = 10 Then
                    Fso.movefile sSourcePath & "\" & arrFiles(i), sDesPath & "\" & arrFiles(i)
                Else
                    Fso.movefile sDesPath & "\" & arrFiles(i), sSourcePath & "\" & arrFiles(i)
                End If
            Next i
        End If
    Else            'DIA DIEM 3
        If UCase(Trim([H32])) = "DIEU KIEN 1" Then
            For i = 1 To 11
                If Choose(i, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1) = 1 Then
                    Fso.movefile sSourcePath & "\" & arrFiles(i), sDesPath & "\" & arrFiles(i)
                Else
                    Fso.movefile sDesPath & "\" & arrFiles(i), sSourcePath & "\" & arrFiles(i)
                End If
            Next i
        Else
            For i = 1 To 11
                 If i = 2 Or i = 10 Then
                    Fso.movefile sSourcePath & "\" & arrFiles(i), sDesPath & "\" & arrFiles(i)
                Else
                    Fso.movefile sDesPath & "\" & arrFiles(i), sSourcePath & "\" & arrFiles(i)
                End If
            Next i
        End If
    End If
        Set oFile = Nothing
        Set Fso = Nothing
    End If
End Sub

Thực ra, cái này dùng Dir và ChDir v.v... nhanh gọn hơn nhiều vì nó là con đẻ.
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn! Học thêm được 1 cách dùng choose.
dùng Dir và ChDir thì viết code như.thế nào? Vui lòng chỉ giúp.
 
Upvote 0
hoi_joker84 đã viết:
Nhờ rút gọn Code!

Mình có đoạn code kiểm tra điều kiện để di chuyển file = FileSystemObject như dưới. Có phương án nào rút gọn được không? hoặc tối ưu hơn không?
Nhấp chuột vào đây để mở rộng...
1. Sao lại dùng sự kiện Change để MoveFile
2. Sao không liệt kê tên các file trên sheet cho thuận tiện khi thêm bớt thay đổi...
3. Mình đếm trong ArrFiles của bạn chỉ có 11 chuỗi, sao vòng lặp lại là For 1 to 11, nghi ngờ sẽ bị lỗi vì ArrFiles(11) không có
4. Nhìn code hoa mắt lắm, nhưng nếu góp ý thì mình sẽ code theo hướng này có thể sẽ gọn code hơn.

PHP: 
Sub MoveAFile(Nguon, Dich)
   With CreateObject("Scripting.FileSystemObject")
      .MoveFile Nguon, Dich
   End With
End Sub

Sub main()
   MoveAFile A, B
   MoveAFile B, A
End Sub
 
Upvote 0
quanghai1969 đã viết:
1. Sao lại dùng sự kiện Change để MoveFile
2. Sao không liệt kê tên các file trên sheet cho thuận tiện khi thêm bớt thay đổi...
3. Mình đếm trong ArrFiles của bạn chỉ có 11 chuỗi, sao vòng lặp lại là For 1 to 11, nghi ngờ sẽ bị lỗi vì ArrFiles(11) không có
4. Nhìn code hoa mắt lắm, nhưng nếu góp ý thì mình sẽ code theo hướng này có thể sẽ gọn code hơn.

PHP: 
Sub MoveAFile(Nguon, Dich)
   With CreateObject("Scripting.FileSystemObject")
      .MoveFile Nguon, Dich
   End With
End Sub

Sub main()
   MoveAFile A, B
   MoveAFile B, A
End Sub
Nhấp chuột vào đây để mở rộng...
Xin trả lời bạn:
1) Dùng sự kiện change vì đối với mỗi hồ sơ khi làm sẽ phải chọn địa điểm ở H31 và điều kiện H32 khi đó lấy những file cần dùng từ Folder Docs sang và chuyển những file ko cần dùng đi tương ứng với giá trị ở 2 ô đó
2) thao tác di chuyển file là đơn giản, không muốn đưa lên sheet làm rối thêm bảng tính
3) Mình đưa code lên bị thiếu Option Base 1 ở đầu. Cảm ơn bạn
4) mình sẽ thử theo cách truyền giá trị cho 1 sub.
cảm ơn các bạn
 
Upvote 0
hoi_joker84 đã viết:
Cảm ơn bạn! Học thêm được 1 cách dùng choose.
dùng Dir và ChDir thì viết code như.thế nào? Vui lòng chỉ giúp.
Nhấp chuột vào đây để mở rộng...

Mình nói không rõ nên bạn hiểu lầm, dùng nhóm lệnh VB (Sử lý File và Folder ) đó chứ không phải dùng lệnh đó. Cụ thể yêu cầu của bạn thì dùng CopyFile và Kill.
 
Upvote 0
sealand đã viết:
Mình nói không rõ nên bạn hiểu lầm, dùng nhóm lệnh VB (Sử lý File và Folder ) đó chứ không phải dùng lệnh đó. Cụ thể yêu cầu của bạn thì dùng CopyFile và Kill.
Nhấp chuột vào đây để mở rộng...
Nếu dùng lệnh CopyFile và Kill thì ta dùng lệnh Name "A" As "B" sẽ gọn hơn
Tuy nhiên dùng FSO thì có thể xử lý được loại file được đặt tên tiếng việt có dấu
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

Bài viết mới nhất

L
Tính thời gian làm việc thực tế (1 người xem)
Trả lời
66
Đọc
14K
YenTon
Y
H
Chia sẻ file in Phiếu điều tra PCGD
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
13
Đọc
630
Phuong7686
P
GPE-Trợ Lý
  • Dán lên cao
[KHẨN] HƯỚNG VỀ ĐỒNG BÀO CHỊU ẢNH HƯỞNG CỦA BÃO YAGI - BẢO YÊN, LÀO CAI
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
91
Đọc
14K
SA_DQ
SA_DQ
SA_DQ
Copilot bình luận về một ván cờ vua
    • Thích
Trả lời
6
Đọc
409
SA_DQ
SA_DQ
92nguyenthanh
  • Question Question
Vba cho file nhập xuất kho
Trả lời
4
Đọc
110
HUONGHCKT
H
C
Fix lỗi Application.InputBox Type:=8
    • Cười
Trả lời
25
Đọc
618
ptm0412
ptm0412
GPE-Trợ Lý
[GPE] TALK SHOW 08: GIẢI QUYẾT VẤN ĐỀ TỐI ƯU HÓA TRONG EXCEL VỚI CÔNG CỤ SOLVER
    • Thích
    • Cảm ơn
Trả lời
4
Đọc
3K
DuongLeHung
D
Gà Công Nghệ
Chế độ chính sách cho giáo viên mầm non giữ trẻ khuyết tật
Trả lời
1
Đọc
58
vanle33
vanle33
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
56
Đọc
22K
dunghtgiga
dunghtgiga
L
  • Question Question
Viết code tìm kiếm các file trong Folder
Trả lời
40
Đọc
12K
lan nguyen0987
L
P
Hyperlink_Cách chuyển cả thư mục và file tổng hợp sang máy khác không bị lỗi
Trả lời
5
Đọc
109
phongvanvu
P
HeSanbi
Tiện ích Web: Tự động nhấn nút "Bỏ qua" quảng cáo Youtube
    • Thích
    • Yêu thích
Trả lời
14
Đọc
1K
ongke0711
ongke0711
ptm0412
Quá tin tưởng vào AI các thể loại
    • Cười
Trả lời
4
Đọc
219
Maika8008
Maika8008
A
  • Question Question
Không tìm được lỗi code
Trả lời
6
Đọc
160
ptm0412
ptm0412
W
Tham chiếu theo chuỗi ký tự
Trả lời
8
Đọc
315
dungpham01
D
tritv.dad
Lấy dữ liệu từ folder các tờ khai thông quan để theo dõi hiệu suất công việc.
Trả lời
8
Đọc
287
BlueSphere
B
GPE-Trợ Lý
MỪNG NGÀY NHÀ GIÁO VIỆT NAM 20/11 (1 người xem)
    • Thích
Trả lời
0
Đọc
3K
GPE-Trợ Lý
GPE-Trợ Lý
SA_DQ
Xin chúc mừng các thầy cô giáo trên cộng đồng nhân 20/11
    • Thích
    • Yêu thích
Trả lời
1
Đọc
135
BuiQuangThuan
B
M
chuyển đổi số thành chữ
Trả lời
15
Đọc
371
dungpham01
D
V
Lỗi copy sheet: the name already exists.
Trả lời
7
Đọc
702
nghiabros
N
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom