Nhờ giúp đỡ sửa code lấy tên sheet

Chào cả nhà.

Mình có tìm được 1 đoạn VBA về việc lấy tên sheet. Do mình không biết gì về VBA cả nên nhờ mọi người sửa giúp mình.
Khi chạy code này thì sẽ bật / tắt các file excel, nếu 1 vài file thì không có vấn đề gì nhưng khi thực hiện 20-30 file thì màn hình cứ nhấp nháy bật / tắt file nhìn rất khó chịu.
Nhờ các bạn xóa đoạn code liên quan đến việc đó giúp mình.
Trân trọng cảm ơn.
——————

Sub FolderCrawler()
FileType = "*.xls*"     'The file type to search for
With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = ThisWorkbook.Path
    .AllowMultiSelect = False
    If .Show = -1 Then
        FilePath = .SelectedItems(1) & ""
    Else
        Exit Sub    'Cancel was pressed
    End If

End With
OutputRow = 2   'The first row of the active sheet to start writing to
ThisWorkbook.ActiveSheet.Range("A" & OutputRow) = FilePath & FileType
OutputRow = OutputRow + 1
Curr_File = Dir(FilePath & FileType)
Do Until Curr_File = ""
    Set FldrWkbk = Workbooks.Open(FilePath & Curr_File, False, True)
    ThisWorkbook.ActiveSheet.Range("A" & OutputRow) = Curr_File
    ThisWorkbook.ActiveSheet.Range("B" & OutputRow).ClearContents   'Clear any previous values
    OutputRow = OutputRow + 1

For Each Sht In FldrWkbk.Sheets
        ThisWorkbook.ActiveSheet.Range("B" & OutputRow) = Sht.Name
        ThisWorkbook.ActiveSheet.Range("A" & OutputRow).ClearContents 'Clear any previous values
        OutputRow = OutputRow + 1
    Next Sht
    FldrWkbk.Close SaveChanges:=False
    Curr_File = Dir
Loop
Set FldrWkbk = Nothing
ThisWorkbook.ActiveSheet.Range("A" & OutputRow) = "---END OF FOLDER---"
End Sub

Thay code trên bằng code này. Sẽ không còn nhấp nháy màn hình nữa

Sub FolderCrawler()
    Application.ScreenUpdating = 0
    Application.DisplayAlerts = 0
    FileType = "*.xls*" 'The file type to search for
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        If .Show = -1 Then
            FilePath = .SelectedItems(1) & ""
        Else
            Exit Sub 'Cancel was pressed
        End If
    End With
    OutputRow = 2 'The first row of the active sheet to start writing to
    ThisWorkbook.ActiveSheet.Range("A" & OutputRow) = FilePath & FileType
    OutputRow = OutputRow + 1
    Curr_File = Dir(FilePath & FileType)
    Do Until Curr_File = ""
        Set FldrWkbk = Workbooks.Open(FilePath & Curr_File, False, True)
        ThisWorkbook.ActiveSheet.Range("A" & OutputRow) = Curr_File
        ThisWorkbook.ActiveSheet.Range("B" & OutputRow).ClearContents 'Clear any previous values
        OutputRow = OutputRow + 1
        For Each Sht In FldrWkbk.Sheets
            ThisWorkbook.ActiveSheet.Range("B" & OutputRow) = Sht.Name
            ThisWorkbook.ActiveSheet.Range("A" & OutputRow).ClearContents 'Clear any previous values
            OutputRow = OutputRow + 1
        Next Sht
        FldrWkbk.Close SaveChanges:=False
        Curr_File = Dir
    Loop
    Set FldrWkbk = Nothing
    ThisWorkbook.ActiveSheet.Range("A" & OutputRow) = "---END OF FOLDER---"
    Application.ScreenUpdating = 1
    Application.DisplayAlerts = 1
End Sub

Thay code trên bằng code này. Sẽ không còn nhấp nháy màn hình nữa

Sub FolderCrawler()
    Application.ScreenUpdating = 0
    Application.DisplayAlerts = 0
    FileType = "*.xls*" 'The file type to search for
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        If .Show = -1 Then
            FilePath = .SelectedItems(1) & ""
        Else
            Exit Sub 'Cancel was pressed
        End If
    End With
    OutputRow = 2 'The first row of the active sheet to start writing to
    ThisWorkbook.ActiveSheet.Range("A" & OutputRow) = FilePath & FileType
    OutputRow = OutputRow + 1
    Curr_File = Dir(FilePath & FileType)
    Do Until Curr_File = ""
        Set FldrWkbk = Workbooks.Open(FilePath & Curr_File, False, True)
        ThisWorkbook.ActiveSheet.Range("A" & OutputRow) = Curr_File
        ThisWorkbook.ActiveSheet.Range("B" & OutputRow).ClearContents 'Clear any previous values
        OutputRow = OutputRow + 1
        For Each Sht In FldrWkbk.Sheets
            ThisWorkbook.ActiveSheet.Range("B" & OutputRow) = Sht.Name
            ThisWorkbook.ActiveSheet.Range("A" & OutputRow).ClearContents 'Clear any previous values
            OutputRow = OutputRow + 1
        Next Sht
        FldrWkbk.Close SaveChanges:=False
        Curr_File = Dir
    Loop
    Set FldrWkbk = Nothing
    ThisWorkbook.ActiveSheet.Range("A" & OutputRow) = "---END OF FOLDER---"
    Application.ScreenUpdating = 1
    Application.DisplayAlerts = 1
End Sub

Không phải là xoá mà là thêm vào đầu chương trình

Application.ScreenUpdating = False

Và cuối chương trình

Application.ScreenUpdating = true

Thử xem nha!

Mình thử được rồi. Cảm ơn bạn

Nhờ các bạn viết giúp mình 1 đoạn code tạo button Clear để trước khi chạy 1 folder mới thì click vào là xóa hết dữ liệu đã có

Khóa học SprinGO phù hợp

Thiết kế Tổng đãi ngộ (Total Rewards) theo khung SHRM

Khóa học “Thiết kế Tổng phần thưởng (Total Reward) chuẩn khung SHRM” giúp bạn nắm vững toàn bộ hệ thống đãi ngộ theo chuẩn...

Xem khóa học