Duyệt file Excel trong sub folder (1 người xem)

[lizzy]

Chào các anh/chị,
Em đang làm quen với VBA trên Excel và gặp một số vấn đề sau nhờ giải đáp giúp:

* Em đang tạo 1 macro insert nội dung từ dòng A~E của sheet1 file hiện tại, vào all sheet cua all file excel nằm trong folder cho trước, kể cả thư mục con của thư mục trên. Tuy nhiên, hiện tại e chỉ insert đc cho các file nằm trong folder cha, còn các file trong folder con (sub folder) thi không insert được, vậy làm sao để duyệt va insert vao cac file excel ở folder con? Trong trường hợp e muốn cho chọn 1 trong 2 Option:
1. Insert vao all sheet.
2. chỉ insert data vao những sheetname có các ký tự cuối là "xyz" thì làm thế nào ạ?
Nội dung các cell tu A~E là công thức, khi copy nó lại refer đến file hiện tại, e muốn là refer đến nội dung trong chính sheet đc insert thì phải làm sao?

Day la doan code thuc hien CT tren hien tai cua e:

Set wb_src = ThisWorkbook
    FileList = Dir(txtDesFolder & "\*.XLS")   [COLOR=Red]'chi lay file excel trong FolderName, neu duyet luon sub folder thi sua lai nhu the nao???[/COLOR]

    Do Until FileList = ""
        'Open file trong destination folder
        Set wb_des  = Workbooks.Open(txtDesFolder & "\" & FileList)
        
       [COLOR=Red] 'Insert doang A~E vao all sheet cua workbooks dang mo, muon insert vao sheetname "..xyz" thi lam sao???[/COLOR]
        For i = 1 To wb_des.Sheets.Count
            For j = 1 To 5
                wb_des.Sheets(i).Rows(j).Insert
                wb_src.Sheets(1).Rows(j).Copy wbd.Sheets(i).Rows(j)
            Next j                
        Next i
      
        wb_des.Close (True)
        FileList = Dir()
        
        
        Set wb_des= Nothing
    Loop

Nho cac anh/chi giup do.

 

[william.hoang74]

Add tất cả hình

Chào cả nhà,
được xem file ví dụ của các anh thật hay và bổ ích.
mình có thử áp dụng vào trường hợp của mình nhưng vẫn chưa hoàn thiện (đã mấy ngày ngâm cứu rùi ). nhờ các anh chỉ giúp xem đang kẹt ở đâu với nhé.
trường hợp của mình muốn là: - Add tất cả các hình (có trong folder đã chỉ định) dựa trên giá trị của Cell mình chọn (Cell chứa tên hình, với định dạng JPG)
Vấn đề: Code của mình chỉ chạy được 1 lần, nếu chạy lần 2nd thì giá trị của i không chịu về 0 mà tiếp tục tăng làm mình không Select được Range mới.
mình gửi file ví dụ, các bác giúp em với.
thanks cả nhà.

 

[ndu96081631]

Chào cả nhà,
được xem file ví dụ của các anh thật hay và bổ ích.
mình có thử áp dụng vào trường hợp của mình nhưng vẫn chưa hoàn thiện (đã mấy ngày ngâm cứu rùi ). nhờ các anh chỉ giúp xem đang kẹt ở đâu với nhé.
trường hợp của mình muốn là: - Add tất cả các hình (có trong folder đã chỉ định) dựa trên giá trị của Cell mình chọn (Cell chứa tên hình, với định dạng JPG)
Vấn đề: Code của mình chỉ chạy được 1 lần, nếu chạy lần 2nd thì giá trị của i không chịu về 0 mà tiếp tục tăng làm mình không Select được Range mới.
mình gửi file ví dụ, các bác giúp em với.
thanks cả nhà.

Code của bạn:

Sub ListFolder(txtDesFolder As String, InSub As Boolean)
    Dim txtFileItem As Scripting.File, txtSubFolder As Scripting.Folder
    [COLOR=#ff0000]Static i As Long[/COLOR], sltRange As Range
    ......................
End Sub
Sub Addpictures()
  [COLOR=#ff0000]Dim i As Long[/COLOR]
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Show: .AllowMultiSelect = False
    ListFolder .SelectedItems(1), True
  End With
End Sub

Sửa thành:

[COLOR=#ff0000]Public i As Long[/COLOR]
Sub ListFolder(txtDesFolder As String, InSub As Boolean)
    Dim txtFileItem As Scripting.File, txtSubFolder As Scripting.Folder
    Dim sltRange As Range
    .............
End Sub
Sub Addpictures()
  [COLOR=#ff0000]i = 0[/COLOR]
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Show: .AllowMultiSelect = False
    ListFolder .SelectedItems(1), True
  End With
End Sub

Những chỗ màu đỏ là chỗ đã sửa
------------------
Nói thêm: Code này vẫn chưa hay, còn phải sửa lại rất nhiều

 

[william.hoang74]

nếu sửa lại phải sửa thế nào ha bác.
lúc trước mình muốn dùng array nhưng chưa quen sử dụng array nên chuyển qua cách này.
tuy nhiên, cách này mình này 1 số bước vẫn còn bị lặp lại (do có sử dụng vòng lặp) nhưng kh6ong biết phải xử lý thế nào.
bác xem có thể chỉnh giúp mình cho code nó chạy hoàn thiện và nhanh hơn được không!!!
trong đoạn code:

For j = 1 To sltRange.Areas.Count
                'lay hinh trong thu muc theo gia tri cua txtdesfolder
                For Each objCell In sltRange.Areas(j)
                    objCell.RowHeight = 50
                    objCell.Offset(0, -1).Select
                    On Error Resume Next
                    ActiveSheet.Pictures.Insert(txtDesFolder & "\" & objCell & ".JPG").Select
                    Selection.ShapeRange.Height = 45
                    Selection.Placement = xlMoveAndSize
                Next objCell
                If j > sltRange.Areas.Count Then j = 1
            Next j

khi Selection có 2 range, duyệt lần đầu thì j duyệt được 2 lần, nhưng khi duyệt vào subfolder thì đến vòng lặp này không lặp được mà thoát ngay. (mình không biết lý do tại sao ).
cảm ơn bác nhiều.

 

[william.hoang74]

mới gửi hỏi bác thì mình sửa được cái lỗi ở vòng lặp

chỉ cần khai báo Static sltRange thay vì Dim sltRange là chạy được.

Public i As Long
Sub ListFolder(txtDesFolder As String, InSub As Boolean)
    Dim txtFileItem As Scripting.File, txtSubFolder As Scripting.Folder
    [COLOR=#ff0000]Static sltRange As Range[/COLOR]
    Dim j As Long, objCell As Range
    'On Error GoTo Thoat
    With New Scripting.FileSystemObject
        With .GetFolder(txtDesFolder)
            i = i + 1
            If i > 1 Then GoTo lapkhongsetrange
            Set sltRange = Application.InputBox("Chon Cell", , , , , , , 8)
lapkhongsetrange:
            For j = 1 To sltRange.Areas.Count
                'lay hinh trong thu muc theo gia tri cua txtdesfolder
                For Each objCell In sltRange.Areas(j)
                    objCell.RowHeight = 50
                    objCell.Offset(0, -1).Select
                    On Error Resume Next
                    ActiveSheet.Pictures.Insert(txtDesFolder & "\" & objCell & ".JPG").Select
                    Selection.ShapeRange.Height = 45
                    Selection.Placement = xlMoveAndSize
                Next objCell
                If j > sltRange.Areas.Count Then j = 1
            Next j
            If InSub Then
                For Each txtSubFolder In .SubFolders
                    ListFolder txtSubFolder.Path, True
                Next txtSubFolder
            End If
        End With
    End With
    'Thoat:
End Sub
--------------------------------------------------------
Sub Addpictures()
  i = 0
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Show: .AllowMultiSelect = False
    ListFolder .SelectedItems(1), True
  End With
End Sub

 

[thanhphuccd]

code này không chạy được trên office 2010 hay sao vậy?

 

[thanhphuccd]

Thì chỉnh lại 1 tí thôi (quan trọng đoạn lấy dung lượng)

Private Sub ListFilesInFolder(FolderName As String, InSub As Boolean)
  Dim FileItem As Scripting.File, SubFolder As Scripting.Folder, FileName As String
  On Error GoTo Thoat
  With New Scripting.FileSystemObject
    With .GetFolder(FolderName)
      For Each FileItem In .Files
        FileName = FolderName & "\" & FileItem.Name
        Dic.Add FolderName & "\" & FileItem.Name, FileLen(FileName)
      Next FileItem
      If InSub Then
        For Each SubFolder In .subFolders
          ListFilesInFolder SubFolder.Path, True
        Next SubFolder
      End If
    End With
  End With
Thoat:
End Sub

Sub GetFileList()
  Dim i As Long
  Set Dic = Nothing
  Set Dic = CreateObject("Scripting.Dictionary")
  Range("A2:B60000").ClearContents
  With Application.FileDialog(4)
    .Show: .AllowMultiSelect = False
    ListFilesInFolder .SelectedItems(1), True
  End With
  With Range("A2").Resize(Dic.Count)
    .Value = WorksheetFunction.Transpose(Dic.Keys)
    .Offset(, 1) = WorksheetFunction.Transpose(Dic.Items)
    .Offset(, 1).NumberFormat = "# ""KB"""
  End With
  Columns("A:B").AutoFit
End Sub

Mình muốn thêm một cột có link file bằng công thức, và môt cột chỉ lấy tên file thôi thì làm thế nào? Bạn giúp mình với.