Ciao
Codice in ThisWorkbook:
Option Explicit
Private Sub Workbook_Open()
Sheets("Results").Cells.ClearContents
[ask_for_subdirs] = "<scegli>"
[ask_for_pie] = "<scegli>"
[A2] = ""
Sheets("Start").Activate
[ask_for_subdirs].Select
End Sub
Codice in Foglio1:
Option Explicit
Private oFileSys As Object, nFiles As Long, nSubDirs As Long, ext_file As String, ir As Long
Sub select_directory()
Dim fd As FileDialog
Set fd = Application.FileDialog(4) ' msoFileDialogFolderPicker
If fd.Show = 0 Then Exit Sub
[A2] = fd.SelectedItems(1)
End Sub
Sub go()
If [A2] = "" Then
MsgBox "Non hai selezionato alcuna cartella da esaminare.", vbCritical + vbOKOnly, "Attenzione"
Exit Sub
End If
If [ask_for_subdirs] = "" Or [ask_for_subdirs] = "<scegli>" Then
MsgBox "Non hai deciso se esaminare o meno anche le sottocartelle.", vbCritical + vbOKOnly, "Attenzione"
Exit Sub
End If
If [ask_for_pie] = "" Or [ask_for_pie] = "<scegli>" Then
MsgBox "Non hai deciso se creare o no anche un grafico a torta sui dati.", vbCritical + vbOKOnly, "Attenzione"
Exit Sub
End If
Sheets("Results").Activate
Call create_report([A2])
Sheets("Results").[A1].Activate
If Sheets("Start").[ask_for_pie] = "Sì" Then
Call create_pie(Sheets("Results").Range("A" & ir + 1).CurrentRegion.Offset(2, 0).Resize(Sheets("Results").Range("A" & ir + 1).CurrentRegion.Rows.Count - 2))
End If
MsgBox "Ho terminato.", vbInformation + vbOKOnly, "Finito!"
End Sub
Private Sub create_report(source As String)
Dim i As Long, j As Long, v As Variant, ext As Variant, c As Collection
Set oFileSys = CreateObject("Scripting.FileSystemObject")
Sheets("Results").[A:B].Clear
nFiles = 0
nSubDirs = 0
ext_file = ""
GetDir source, i
With Sheets("Results")
.Cells(i + 2, 1) = "Totale " & nFiles & " files in " & nSubDirs & " subdirectory."
.Cells(i + 2, 1).Font.Bold = True
.Cells(i + 2, 1).Font.ColorIndex = 5
.Cells(i + 3, 1) = "Statistiche sui singoli files:"
.Cells(i + 3, 1).Font.Italic = True
End With
ext_file = Replace(ext_file & "@", ";@", "")
v = Split(ext_file, ";")
j = i + 3
ir = j 'da qui inizia il range dei valori da "tortizzare"
Set c = New Collection
Set c = duplicates(v)
For Each ext In c
j = j + 1
Sheets("Results").Cells(j, 1) = ext
Sheets("Results").Cells(j, 2) = count_occurrences(v, CStr(ext))
Next
End Sub
Private Function GetDir(dir, i As Long) As Long
Dim oFolder As Object, oFolders As Object, oFiles As Object, oFold As Object, oFile As Object
Set oFolder = oFileSys.GetFolder(dir)
Set oFolders = oFolder.SubFolders
Set oFiles = oFolder.Files
If i = 0 Then
i = i + 1
nSubDirs = nSubDirs + 1
Sheets("Results").Cells(i, 1) = oFolder.Path
Sheets("Results").Cells(i, 1).Font.Bold = 1
End If
On Error GoTo gest_err
For Each oFile In oFiles
i = i + 1
If i > Rows.Count Then MsgBox "Limite del foglio raggiunto!": Exit Function
Sheets("Results").Cells(i, 2) = oFile.Name
nFiles = nFiles + 1
If InStrRev(oFile, ".") = 0 Then
ext_file = ext_file & "<nessuna estensione>" & ";"
Else
ext_file = ext_file & Mid(oFile, InStrRev(oFile, ".") + 1) & ";"
End If
Next
If Sheets("Start").[ask_for_subdirs] = "Sì" Then
For Each oFold In oFolders
i = i + 1
If i > Rows.Count Then MsgBox "Limite del foglio raggiunto!": Exit Function
nSubDirs = nSubDirs + 1
Sheets("Results").Cells(i, 1) = oFold.Path & "\" & oFold.Name
Sheets("Results").Cells(i, 1).Font.Bold = 1
GetDir oFold, i
Next
End If
Exit Function
gest_err:
If Err.Number = 70 Then Resume Next
End Function
Private Sub create_pie(r As Range)
r.Select
Charts.Add
With ActiveChart
.ChartType = xlPie
.SetSourceData source:=r, PlotBy:=xlColumns
.Location Where:=xlLocationAsNewSheet
.HasTitle = True
.ChartTitle.Characters.Text = "Cartella " & Sheets("Start").[A2] & vbLf & IIf(Sheets("Start").[ask_for_subdirs] = "Sì", "con sottocartelle", "senza sottocartelle")
.ChartTitle.Font.Size = 10
With ActiveChart.SeriesCollection(1)
.ApplyDataLabels AutoText:=True, LegendKey:= _
False, HasLeaderLines:=True, ShowSeriesName:=False, ShowCategoryName:= _
False, ShowValue:=True, ShowPercentage:=True, ShowBubbleSize:=False
With .DataLabels
.AutoScaleFont = True
.NumberFormat = "0.00%"
With .Font
.Name = "Calibri"
.FontStyle = "Normale"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.Background = xlAutomatic
End With
End With
End With
End With
End Sub
Private Function count_occurrences(vettore As Variant, search As String)
Dim s As String
s = Join(vettore, vbNullChar) & vbNullChar
s = LCase(s)
search = LCase(search)
count_occurrences = Len(Replace(s, search & vbNullChar, search & vbNullChar & "*")) - Len(s)
End Function
Private Function duplicates(vettore As Variant) As Collection
Dim v As Variant, dups As Collection
Set dups = New Collection
On Error Resume Next
For Each v In vettore
dups.Add CStr(v), v
Next
On Error GoTo 0
Set duplicates = dups
End Function
segue esempio:
http://www.sendspace.com/file/mo4ivn