Nhờ lọc những Folder cấp 1 (1 người xem)

nguyenmanhnam · 5/12/12

Nhờ các bác lọc giúp em các Folder cấp 1 tức chỉ có 1 ký tự \ trong file đính kèm
(có thể dùng cách lọc thông thường không dùng cột phụ, hoặc cách làm bằng VBA)
------
Thành thật xin lỗi bác dhn46 do sơ xuất nên em viết nhầm đầu bài.

ndu96081631 · 5/12/12

nguyenmanhnam đã viết:
Nhờ các bác lọc giúp em các Folder cấp 1 tức chỉ có 1 ký tự \ trong file đính kèm
(cách lọc thông thường không dùng cột phụ và VBA)

Dùng Advanced Filter với cell điều kiện là =COUNTIF($A2,"*\*\*")=0

dhn46 · 5/12/12

nguyenmanhnam đã viết:
Nhờ các bác lọc giúp em các Folder cấp 1 tức chỉ có 1 ký tự \ trong file đính kèm
(cách lọc thông thường không dùng cột phụ và VBA)

Box lập trình mà không cho dùng VBA thì làm sao được hả bạn?

ndu96081631 · 5/12/12

dhn46 đã viết:
Box lập trình mà không cho dùng VBA thì làm sao được hả bạn?

Thế thì bạn cứ viết code, có sao đâu! Tác giả không dùng sẽ có người khác dùng
Ẹc... Ẹc... cứ giải thuật hay thì đều đáng học hỏi cả

nguyenmanhnam · 5/12/12

ndu96081631 đã viết:
Dùng Advanced Filter với cell điều kiện là =COUNTIF($A2,"*\*\*")=0

Thật tuyệt vời, em nghĩ cái này dùng Advanced Filter thế nào cũng giải quyết được vấn đề, nhưng không nghĩ ra được công thức trên của thày.

Vậy bài này có thể dùng các cách nào nữa không ah? Em muốn đồng thời kết quả bài này học tập thêm.

ndu96081631 · 5/12/12

nguyenmanhnam đã viết:
Thật tuyệt vời, em nghĩ cái này dùng Advanced Filter thế nào cũng giải quyết được vấn đề, nhưng không nghĩ ra được công thức trên của thày.

Vậy bài này có thể dùng các cách nào nữa không ah? Em muốn đồng thời kết quả bài này học tập thêm.

Công thức điều kiện vầy cũng được:

Mã:

=ISERROR(FIND("\",A2,FIND("\",A2)+1))

hoặc

Mã:

=LEN(A2)-LEN(SUBSTITUTE(A2,"\",""))=1

Tôi nghĩ vẫn còn nhiều cách khác nữa

dhn46 · 5/12/12

Bạn tham khảo VBA

Mã:

Function Tach(Chuoi As Range)
Dim Arr
Arr = Split(Trim(Chuoi), "\")
If UBound(Arr) > -1 Then
    Tach = Arr(1)
End If
End Function

ndu96081631 · 5/12/12

dhn46 đã viết:
Bạn tham khảo VBA

Mã:

Function Tach(Chuoi As Range) Dim Arr Arr = Split(Trim(Chuoi), "\") If UBound(Arr) > -1 Then Tach = Arr(1) End If End Function

Ấy... bài này yêu cầu LỌC chứ có phải TÁCH gì đâu chứ ---> Tức là cứ nhìn chuổi cột A, thấy em nào chỉ có 1 dấu "\" thì lọc sang cột khác

dhn46 · 5/12/12

ndu96081631 đã viết:
Ấy... bài này yêu cầu LỌC chứ có phải TÁCH gì đâu chứ ---> Tức là cứ nhìn chuổi cột A, thấy em nào chỉ có 1 dấu "\" thì lọc sang cột khác

Em sửa như thế này có được không ạ?

Mã:

Sub loc()
Dim Arr, sArr, i, k As Long


Arr = Range("A1:A" & Range("A65536").End(xlUp).Row)
ReDim sArr(1 To UBound(Arr), 1 To 1)


With CreateObject("scripting.dictionary")
For i = 1 To UBound(Arr, 1)
    If InStr(4, Trim(Arr(i, 1)), "\") = 0 Then
        If Not .exists(Arr(i, 1)) Then
            k = k + 1
            .Add Arr(i, 1), k
            sArr(k, 1) = Arr(i, 1)
        End If
    End If
Next
End With


[C2:C1000].ClearContents
[C2].Resize(UBound(sArr, 1)) = sArr
End Sub

Quang_Hải · 5/12/12

dhn46 đã viết:

Em sửa như thế này có được không ạ?

Mã:

Sub loc()
Dim Arr, sArr, i, k As Long


Arr = Range("A1:A" & Range("A65536").End(xlUp).Row)
ReDim sArr(1 To UBound(Arr), 1 To 1)


With CreateObject("scripting.dictionary")
For i = 1 To UBound(Arr, 1)
    If InStr(4, Trim(Arr(i, 1)), "\") = 0 Then
        If Not .exists(Arr(i, 1)) Then
            k = k + 1
            .Add Arr(i, 1), k
            sArr(k, 1) = Arr(i, 1)
        End If
    End If
Next
End With


[C2:C1000].ClearContents
[C2].Resize(UBound(sArr, 1)) = sArr
End Sub

Bài này nếu viết code thì cũng nên dựa vào advanced filter viết cho khỏe hén.

ndu96081631 · 5/12/12

dhn46 đã viết:

Em sửa như thế này có được không ạ?

Mã:

Sub loc()
Dim Arr, sArr, i, k As Long


Arr = Range("A1:A" & Range("A65536").End(xlUp).Row)
ReDim sArr(1 To UBound(Arr), 1 To 1)


With CreateObject("scripting.dictionary")
For i = 1 To UBound(Arr, 1)
    If InStr(4, Trim(Arr(i, 1)), "\") = 0 Then
        If Not .exists(Arr(i, 1)) Then
            k = k + 1
            .Add Arr(i, 1), k
            sArr(k, 1) = Arr(i, 1)
        End If
    End If
Next
End With


[C2:C1000].ClearContents
[C2].Resize(UBound(sArr, 1)) = sArr
End Sub

Bài này thì cần gì đến Dic nhỉ?
Tôi làm vầy:

Mã:

Sub loc2()
  Dim sArray, Arr()
  Dim i as Long, k As Long
  Dim tmp1 As String, tmp2 As String
  On Error Resume Next
  sArray = Range([A1], [A65536].End(xlUp)).Resize(, 2).Value
  ReDim Arr(1 To UBound(sArray), 1 To 2)
  For i = 1 To UBound(sArray, 1)
    tmp1 = sArray(i, 1)
    tmp2 = sArray(i, 2)
    If Len(tmp1) Then
      If Not (tmp1 Like "*\*\*") Then
        k = k + 1
        Arr(k, 1) = tmp1
        Arr(k, 2) = tmp2
      End If
    End If
  Next
  If k Then Range("D1").Resize(k, 2) = Arr
End Sub

Thuật toán giống với COUNTIF ở bài 2

dhn46 · 5/12/12

Bài này thì cần gì đến Dic nhỉ?
Tôi làm vầy:

Thầy Ndu: Code này không lọc các Folder bị trùng.

Quang_Hải · 6/12/12

Bài này dùng Filter cũng được

PHP:

Sub loc()
Range([B2], [B65536].End(3)).Offset(, 1).Formula = "=COUNTIF(A2,""*\*\*"")=0"
With Range([A1], [C65536].End(3))
   .AutoFilter 3, True
   .SpecialCells(12).Copy [E1]
   .AutoFilter
End With
Range("C:C, G:G").Clear
End Sub

ndu96081631 · 6/12/12

dhn46 đã viết:
Thầy Ndu: Code này không lọc các Folder bị trùng.

Bạn lo xa quá! Bạn có bao giờ thấy trong máy tính của mình có 2 folder trùng tên và trùng cả đường dẫn không?
Ẹc... Ẹc... không đời nào!

Quang_Hải · 6/12/12

ndu96081631 đã viết:

Bài này thì cần gì đến Dic nhỉ?
Tôi làm vầy:

Mã:

Sub loc2()
  Dim sArray, Arr()
  Dim i as Long, k As Long
  Dim tmp1 As String, tmp2 As String
  On Error Resume Next
  sArray = Range([A1], [A65536].End(xlUp)).Resize(, 2).Value
  ReDim Arr(1 To UBound(sArray), 1 To 2)
  For i = 1 To UBound(sArray, 1)
    tmp1 = sArray(i, 1)
    tmp2 = sArray(i, 2)
    If Len(tmp1) Then
    [COLOR=#0000ff][SIZE=2][I][B]  If Not (tmp1 Like "*\*\*") Then[/B][/I][/SIZE][/COLOR]
        k = k + 1
        Arr(k, 1) = tmp1
        Arr(k, 2) = tmp2
      End If
    End If
  Next
  If k Then Range("D1").Resize(k, 2) = Arr
End Sub

Thuật toán giống với COUNTIF ở bài 2

Em đọc code và thắc mắc tại sao dòng màu xanh có thêm 2 dấu ( ). Anh NDU giải thích giúp em.

ndu96081631 · 6/12/12

quanghai1969 đã viết:
Em đọc code và thắc mắc tại sao dòng màu xanh có thêm 2 dấu ( ). Anh NDU giải thích giúp em.

Giống vầy nè:
X AND X cho kết quả TRUE hoặc FALSE
Giờ tôi muốn điều ngược lại, tôi viết
NOT (X AND Y) chứ chả lẽ ghi NOT X AND Y sao? Khác nhau à nha
Ở trên cũng thế ---> Sợ nếu không có dấu ngoặc thì cha Bill hiểu lầm tôi muốn lấy Not tmp1 đi so sánh với "*\*\*"
Vậy thôi

nguyenmanhnam · 6/12/12

Nhờ thày chỉ dùm em cách chỉ lấy những Folder cấp 1

PHP:

 Public Dic As Object
Private Sub FolderList(FolderName As String, InSub As Boolean)
  Dim SubFld As Object
  On Error Resume Next
  With CreateObject("Scripting.FileSystemObject")
    With .GetFolder(FolderName)
      Dic.Add .Path, .Size / 1024
      If InSub Then
        For Each SubFld In .SubFolders
          FolderList SubFld.Path, True
        Next SubFld
      End If
    End With
  End With
End Sub

PHP:

Sub Main()
  Dim Arr, i As Long, Item
  Application.ScreenUpdating = False
  Set Dic = CreateObject("Scripting.Dictionary")
  On Error Resume Next
  Range("A2:B10000").ClearContents
  With CreateObject("Shell.Application")
    FolderList .BrowseForFolder(0, "", 1).Self.Path, True
  End With
  Arr = Dic.Keys
  ReDim Arr(Dic.Count - 1, 1)
  For Each Item In Dic.Keys
    Arr(i, 0) = CStr(Item)
    Arr(i, 1) = Dic.Item(Item)
    i = i + 1
  Next
  With Range("A2").Resize(i, 2)
    .Offset(, 1).Resize(, 1).NumberFormat = "#,##0 ""KB"""
    .Value = Arr
  End With
  Application.ScreenUpdating = True
End Sub

Hai đoạn Code trên em có tìm được Code của thày Ndu về hiện dung lượng Folder, em xin phép nhờ thày giúp cho cách làm thế nào nó chỉ hiện Folder cấp 1 thôi.

ndu96081631 · 6/12/12

nguyenmanhnam đã viết:
Hai đoạn Code trên em có tìm được Code của thày Ndu về hiện dung lượng Folder, em xin phép nhờ thày giúp cho cách làm thế nào nó chỉ hiện Folder cấp 1 thôi.

Trước đây tôi có viết code lấy List file dùng lệnh DOS, giờ sửa lại nó tí để lấy folder list thôi:

Mã:

Function GetFolderList(ByVal Folder As String, ByVal Search As String, ByVal InSub As Boolean)
  Dim sComm As String, tmp As String, tmpFile, Arr, sPath As String
  On Error Resume Next
  If Right(Folder, 1) <> "\" Then Folder = Folder & "\"
  sPath = """" & Folder & "*" & Search & "*"""
  With CreateObject("Scripting.FileSystemObject")
    tmpFile = .GetTempName
    sComm = "DIR " & sPath & " /ON /B /[COLOR=#ff0000][/COLOR]A[COLOR=#ff0000]D-S[/COLOR] " & IIf(InSub, "/S", " ") & " >" & tmpFile
    CreateObject("Wscript.Shell").Run "cmd /u /c " & sComm, 0, True
    With .OpenTextFile(tmpFile, 1, , -2)
      tmp = Trim(.ReadAll)
      If Right(tmp, 2) = vbCrLf Then tmp = Left(tmp, Len(tmp) - 2)
      If Len(tmp) Then GetFolderList = Split(tmp, vbCrLf)
      .Close
    End With
  End With
  Kill tmpFile
End Function

Mã:

Sub Main()
  Dim sArray, Arr()
  Dim i As Long
  Dim Folder As String, tmp As String
  On Error Resume Next
  Range("A2:B10000").ClearContents
  Folder = CreateObject("Shell.Application").BrowseForFolder(0, "", 1).Self.Path
  If Right(Folder, 1) <> "\" Then Folder = Folder & "\"
  sArray = GetFolderList(Folder, "", [COLOR=#ff0000]False[/COLOR])
  ReDim Arr(1 To UBound(sArray), 1 To 2)
  If IsArray(Arr) Then
    With CreateObject("Scripting.FileSystemObject")
      For i = 1 To UBound(Arr)
        tmp = Folder & sArray(i)
        Arr(i, 1) = tmp
        Arr(i, 2) = .GetFolder(tmp).Size / 1024
      Next
    End With
    With Range("A2").Resize(UBound(Arr), 2)
      .Offset(, 1).Resize(, 1).NumberFormat = "#,##0 ""KB"""
      .Value = Arr
    End With
  End If
End Sub

Chạy sub Main sẽ có kết quả

Nhờ lọc những Folder cấp 1 (1 người xem)

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

Thành viên tiêu biểu

File đính kèm

Huyền thoại GPE

Hướng tới tương lai

Huyền thoại GPE

Thành viên tiêu biểu

Huyền thoại GPE

Hướng tới tương lai

Huyền thoại GPE

Hướng tới tương lai

Thành viên gạo cội

Huyền thoại GPE

Hướng tới tương lai

Thành viên gạo cội

Huyền thoại GPE

Thành viên gạo cội

Huyền thoại GPE

Thành viên tiêu biểu

Huyền thoại GPE

Đếm ngược thời gian