Wednesday, July 16, 2014

How to List or Fetch all the details of Files and SubFolders from a Specific Path using Excel VBA Macro

Macro to List or Fetch all the details of Files and SubFolders with Files from a Folder or Specific Path

Sub List_All_SubFolders_Files()
    Dim SrcPath As String       
    Dim FSO As Object   
    Dim SrcFolder As Object
    Dim S_Folder As Object
    Dim S_File As Object    
    Dim FileExt As String
    Dim WS As Object    
     
    SrcPath = ActiveSheet.Range("B1").Value
    Set WS = ThisWorkbook.ActiveSheet
        
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SrcFolder = FSO.GetFolder(SrcPath)

    If Right(SrcPath, 1) = "\" Then
        SrcPath = Left(SrcPath, Len(SrcPath) - 1)
    End If
    
    If (SrcFolder.Files.Count = 0) And (SrcFolder.SubFolders.Count = 0) Then
        MsgBox "Src Folder Doesnot Have Any Subfolders/Files", vbOKCancel, 
                       "Src Folder Is Empty"
        Exit Sub
    End If

    ActiveSheet.Range("A3:G1000").Select
    Selection.Clear

    Z = 0
    K = 3

    MFC = SrcFolder.Files.Count 'Main Folder Files Count
    
        WS.Cells(K, 1) = SrcFolder.Name
        WS.Cells(K, 1).Interior.ColorIndex = 37
        WS.Cells(K, 1).Font.Bold = True
        WS.Cells(K, 2) = SrcFolder.Path
        WS.Cells(K, 3) = Round(SrcFolder.Size / 1024) & " KB"
        WS.Cells(K, 4) = SrcFolder.Type
        WS.Cells(K, 5) = SrcFolder.DateLastModified
        WS.Cells(K, 6).Select
        WS.Hyperlinks.Add Anchor:=Selection, Address:= _
                SrcFolder.Path, TextToDisplay:="Click Here to Open"
        
    If (Round((SrcFolder.Size / 1024) / 1024) = 0) Then
        WS.Cells(K, 7) = "<1 MB"
    Else
        WS.Cells(K, 7) = Round((SrcFolder.Size / 1024) / 1024) & " MB"
    End If
    K = K + 1

For Y = K To MFC
    For Each File In SrcFolder.Files
    
        M_File_Name = File.Name
        M_File_Path = File.Path
        M_File_Size = Round(File.Size / 1024) & " KB"
        
            If (Round((File.Size / 1024) / 1024) = 0) Then
                MB_File_Size = "<1 MB"
            Else
               MB_File_Size = Round((File.Size / 1024) / 1024) & " MB"
            End If
    
        M_File_Type = File.Type
        M_File_Modified = File.DateLastModified
        
        WS.Cells(Y, 1) = M_File_Name
        WS.Cells(Y, 2) = M_File_Path
        WS.Cells(Y, 3) = M_File_Size
        WS.Cells(Y, 4) = M_File_Type
        WS.Cells(Y, 5) = M_File_Modified
        WS.Cells(Y, 6).Select
        WS.Hyperlinks.Add Anchor:=Selection, Address:= _
                M_File_Path, TextToDisplay:="Click Here to Open"
        WS.Cells(Y, 7) = MB_File_Size
        Y = Y + 1
        Z = Z + 1
    
    Next File
Next Y

K = K + Z

If (SrcFolder.SubFolders.Count > 0) Then

    For Each SubFolder In SrcFolder.SubFolders
    If (SubFolder.Files.Count > 0) Then
    
            S_Folder_Name = SubFolder.Name
            S_Folder_Path = SubFolder.Path
            S_Folder_Size = Round(SubFolder.Size / 1024) & " KB"
            
                If (Round((SubFolder.Size / 1024) / 1024) = 0) Then
                    SMB_Folder_Size = "<1 MB"
                Else
                    SMB_Folder_Size = Round((SubFolder.Size / 1024) / 1024) & " MB"
                End If
            
            S_Folder_Type = SubFolder.Type
            S_Folder_Modified = SubFolder.DateLastModified
            
            SFC = SubFolder.Files.Count ' Sub Folder Files Count
        
        For X = K To (K + SFC)
        
            WS.Cells(X, 1) = S_Folder_Name
            WS.Cells(X, 1).Interior.ColorIndex = 36
            
            WS.Cells(X, 1).Font.Bold = True
            WS.Cells(X, 2) = S_Folder_Path
            WS.Cells(X, 3) = S_Folder_Size
            WS.Cells(X, 4) = S_Folder_Type
            WS.Cells(X, 5) = S_Folder_Modified
            WS.Cells(X, 6).Select
            WS.Hyperlinks.Add Anchor:=Selection, Address:= _
                    S_Folder_Path, TextToDisplay:="Click Here to Open"
            WS.Cells(X, 7) = SMB_Folder_Size
       
            For Each File In SubFolder.Files
                X = X + 1
                S_File_Name = File.Name
                S_File_Path = File.Path
                S_File_Size = Round(File.Size / 1024) & " KB"
                
                        If (Round((File.Size / 1024) / 1024) = 0) Then
                            SMB_File_Size = "<1 MB"
                        Else
                           SMB_File_Size = Round((File.Size / 1024) / 1024) & " MB"
                        End If
            
                S_File_Type = File.Type
                S_File_Modified = File.DateLastModified
                
                WS.Cells(X, 1) = S_File_Name
                WS.Cells(X, 2) = S_File_Path
                WS.Cells(X, 3) = S_File_Size
                WS.Cells(X, 4) = S_File_Type
                WS.Cells(X, 5) = S_File_Modified
                WS.Cells(X, 6).Select
                WS.Hyperlinks.Add Anchor:=Selection, Address:= _
                        S_File_Path, TextToDisplay:="Click Here to Open"
                WS.Cells(X, 7) = SMB_File_Size
            
                K = K + 1
            Next File

            K = K + 1
        Next X

    End If
    Next SubFolder
End If

Set FSO = Nothing

End Sub



--------------------------------------------------------------------------------------------------------
Thanks, TAMATAM ; Business Intelligence & Analytics Professional
--------------------------------------------------------------------------------------------------------

Friday, July 11, 2014

How to Select Used Range Excluding Headers in Excel using VBA Macro

Excel VBA Macro to Select Used Range Excluding Headers
Sub Used_Rows_Columns_Range()
Dim RC As Long
Dim CC As Long
Dim Sort_Range As String

'To Get  Count of Columns and Rows with data in Used Range(Eg: 1,2,3)
RC = ActiveSheet.Cells.Find(what:="*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row

CC = ActiveSheet.Cells.Find(what:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column

' To Get Column Index Name in Used Range(Eg: A,B,C..)
CN = Split(Cells(, CC).Address, "$")(1)
Data_Range = "$A$2" & " : " & "$" & CN & "$" & RC
ActiveSheet.Range(Data_Range).Select


End Sub

Example :

Other References for Dynamic Used Range :

How to Select Dynamic Actual Used Range in Excel


Thanks, TAMATAM

Sunday, July 6, 2014

Excel VBA Macro to Store Each Sheet Name in an Array

How to Store Each Sheet Name in an Array with VBA Macro
Sub ShtNamesIntoArray()

Dim SheetNames() As String
ReDim SheetNames(1 To ActiveWorkbook.Sheets.Count) ' Resizing Array

For X = 1 To Sheets.Count
SheetNames(X) = Sheets(X).Name
Next X

'To display the sheet name First Column of Active Sheet
For X = 1 To Sheets.Count
ActiveSheet.Cells(X, 1) = SheetNames(X)
Next X

End Sub

To Understand More about Arrays , go through the below Link :


Thanks, TAMATAM

Saturday, July 5, 2014

Macro to Sort one specific Column then give Rank in another specific Column

Macro to Sort one Specific Column in Ascending and another Specific Column in Descending then give Rank in another Specific Column
Model - I :
Sub Sort_Ascend_Descend_Rank()
Dim RC As Long
Dim CC As Long
Dim Sort_Range As String

'To Get Column Index Number in Used Range(Eg: 1,2,3)
RC = ActiveSheet.UsedRange.Rows.Count
CC = ActiveSheet.UsedRange.Columns.Count 

' To Get Column Index Name in Used Range(Eg: A,B,C..)
CN = Split(Cells(, CC).Address, "$")(1) 

Sort_Range = "$A$1" & " : " & "$" & CN & "$" & RC

For X = 1 To CC
If ActiveSheet.Cells(1, X) = "Product Id" Then
S_1 = Cells(1, X).Column '? Sorting Column-1 Number(Eg: 1,2,3)
SC_1 = Split(Cells(, S_1).Address, "$")(1) '? Sorting Column-1 Index Name(Eg: A,B,C..)

ElseIf ActiveSheet.Cells(1, X) = "Sample" Then
S_2 = Cells(1, X).Column '? Sorting Column-2 Index Number(Eg: 1,2,3)
SC_2 = Split(Cells(, S_2).Address, "$")(1) '? Sorting Column-2 Index Name(Eg: A,B,C..)

ElseIf ActiveSheet.Cells(1, X) = "Rank" Then
RNK_C = Cells(1, X).Column '? Ranking Column Index Number(Eg: 1,2,3)
RNK_CN = Split(Cells(, S_2).Address, "$")(1) '? Ranking Column Index Name(Eg: A,B,C..)

End If
Next X

SC1_Range = "$" & SC_1 & "$1" & " : " & "$" & SC_1 & "$" & RC
SC2_Range = "$" & SC_2 & "$1" & " : " & "$" & SC_2 & "$" & RC

ActiveSheet.Range(Sort_Range).Select

ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range(SC1_Range), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

ActiveSheet.Sort.SortFields.Add Key:=Range(SC2_Range), _
    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range(Sort_Range)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

X = 0
Y = 0
Z = 0
K = 0

For X = 2 To RC 'Total Rows in Used Range

For Y = X To RC

If Cells(Y, S_1) <> Cells(X, S_1) Then Exit For

If (Cells(Y - 1, S_2) <> Cells(Y, S_2)) Then
Z = (Z + 1)
Cells(Y, RNK_C) = Z
K = K + 1

ElseIf (Cells(Y - 1, S_1) = Cells(Y, S_1)) And (Cells(Y - 1, S_2) = Cells(Y, S_2)) Then
Cells(Y, RNK_C) = Z
K = K + 1

Else
Z = Z + 1
Cells(Y, RNK_C) = Z
K = K + 1

End If
Next Y

X = (X + K) - 1
Z = 0
K = 0
Next X
ActiveSheet.Range("$A$1").Select
MsgBox "Job Over", vbOKOnly, "Done"

End Sub
----------------------------------------------------------------------------------------
Model - II :

Sub Sort_Ascend_Descend_Rank()

Dim RC As Long
Dim CC As Long
Dim Sort_Range As String

On Error Resume Next

RC = ActiveSheet.UsedRange.Rows.Count
CC = ActiveSheet.UsedRange.Columns.Count 'To Get Column Index Number in Used Range
CN = Split(Cells(, CC).Address, "$")(1) ' To Get Column Index Name in Used Range

Sort_Range = "$A$1" & " : " & "$" & CN & "$" & RC

'Loop to Convert Each Column As a Named Range with Heading Name

For X = 1 To CC 
If ActiveSheet.Cells(1, X) <> "" Then ActiveSheet.Cells(1, X).EntireColumn.Select
Selection.Name = Cells(1, X).Value
Next X

S_1 = ActiveSheet.Range("Gs_Id").Column ' ? Sorting Column-2 Number ?
S_2 = ActiveSheet.Range("Payout_Weight").Column ' ? Sorting Column-2 Number ?
RNK_C = ActiveSheet.Range("Rank").Column 'Ranking Column Number

ActiveSheet.Range(Sort_Range).Select

ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("Gs_Id"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

ActiveSheet.Sort.SortFields.Add Key:=Range("Payout_Weight"), _
    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    
    With ActiveSheet.Sort
        .SetRange Range(Sort_Range)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

X = 0
Y = 0
Z = 0
K = 0

For X = 2 To RC 'Total Rows in Used Range

For Y = X To RC
If Cells(Y, S_1) <> Cells(X, S_1) Then Exit For

If (Cells(Y - 1, S_2) <> Cells(Y, S_2)) Then
Z = (Z + 1)
Cells(Y, RNK_C) = Z
K = K + 1

ElseIf (Cells(Y - 1, S_1) = Cells(Y, S_1)) And (Cells(Y - 1, S_2) = Cells(Y, S_2)) Then
Cells(Y, RNK_C) = Z
K = K + 1

Else
Z = Z + 1
Cells(Y, RNK_C) = Z
K = K + 1

End If
Next Y

X = (X + K) - 1
Z = 0
K = 0
Next X
ActiveSheet.Range("$A$1").Select
MsgBox "Job Over", vbOKOnly, "Done"

End Sub


--------------------------------------------------------------------------------------------------------
Thanks, TAMATAM ; Business Intelligence & Analytics Professional
--------------------------------------------------------------------------------------------------------

Wednesday, July 2, 2014

How to Find Count or Sum of Sub Totals and Grand Totals Based on Cell Color Index Number in Excel

Macro to Find Count or Sum of Sub-Sub Totals and Grand Totals Based on Cell Color Index Number

Sub Grand_Sub_Totals_Count()

X = 0
Z = 0
K = 0

CC = InputBox("Please Enter Column In Which You Want to Find Counts" & vbNewLine _
& "Eg: 1 , 2 , 3 ...", "Please Enter Counting Column Number")

If CC = vbNullString Then Exit Sub

CC = Val(CC) 'Converting String Input to a Number Value


For A = 1 To 2500 'Records/Rows Range

"Put '1' in Each Cell of the Counting Column then Run Macro"
"Color-I Criteria :"

If (ActiveSheet.Cells(A, CC) = 1) And (ActiveSheet.Cells(A, CC).Interior.ColorIndex = -4142) Then
X = X + 1 ' Adding Sub-Sub Totals

"Color-II Criteria :"
ElseIf (ActiveSheet.Cells(A, CC).Interior.ColorIndex = 35) Then

ActiveSheet.Cells(A, CC).Value = X
Z = Z + X ' Adding Sub Totals

X = 0
End If

"Color-III Criteria :"
If (ActiveSheet.Cells(A, CC).Interior.ColorIndex = 43) Then

ActiveSheet.Cells(A, CC).Value = Z
K = K + Z ' Adding Grand Totals

Z = 0
End If

If (ActiveSheet.Cells(A, CC).Interior.ColorIndex = 14) Then

ActiveSheet.Cells(A, CC).Value = K

K = 0
End If

Next A

End Sub

Featured Post from this Blog

How to compare Current Snapshot Data with Previous Snapshot in Power BI

How to Dynamically compare two Snapshots Data in Power BI Scenario: Suppose, we have a sample Sales data, which is stored with Monthly Snaps...

Popular Posts from this Blog