AW: Abfragestatistik via VBA
13.03.2012 21:57:21
Nepumuk
Hallo,
versuch es mal damit:
Die Textdateien die dabei im selben Ordner in dem sich auch die Mappe befindet entstehen, sind versteckte Systemdateien welche "normalerweise" für den Benutzer unsichtbar bleiben.
Option Explicit
Private Type DATASET
strSearchTerm As String * 50
lngCount As Long
End Type
Public Sub Search()
'
' Keyboard Shortcut: Ctrl+s
'
ActiveSheet.AutoFilter.Range.AutoFilter Field:=1, _
Criteria1:=Range("L2").Text
Columns("C:J").WrapText = True
Call Statistic(Range("D2").Text)
End Sub
Private Sub Statistic(ByVal pvstrSearchTerm As String)
Dim intFileNumber As Integer
Dim lngDatasetCounter As Long
Dim strFile As String
Dim udtDataset As DATASET
Reset
intFileNumber = FreeFile
strFile = ThisWorkbook.Path & "\Statistic_" & _
Environ$("USERNAME") & ".log"
Open strFile For Random Access Read Write As _
#intFileNumber Len = Len(udtDataset)
Do
lngDatasetCounter = lngDatasetCounter + 1
Get #intFileNumber, lngDatasetCounter, udtDataset
If EOF(intFileNumber) Then
udtDataset.strSearchTerm = pvstrSearchTerm
udtDataset.lngCount = 1
Exit Do
End If
If StrComp(Trim$(udtDataset.strSearchTerm), _
pvstrSearchTerm, vbTextCompare) = 0 Then
udtDataset.lngCount = udtDataset.lngCount + 1
Exit Do
End If
Loop
Put #intFileNumber, lngDatasetCounter, udtDataset
Close #intFileNumber
Call SetAttr(strFile, vbHidden Or vbSystem)
End Sub
Public Sub Analysis()
Dim intFileNumber As Integer
Dim lngDatasetCounter As Long, lngRow As Long
Dim strPath As String, strFileName As String, strUser As String
Dim udtDataset As DATASET
With Worksheets("Statistics")
.UsedRange.ClearContents
With Range("A1:C1")
.Value2 = Array("User name", "Search term", "Count")
.Font.Bold = True
End With
lngRow = 1
Reset
intFileNumber = FreeFile
strPath = ThisWorkbook.Path & "\"
strFileName = Dir$(strPath & "Statistic_*.log", _
vbHidden Or vbSystem)
Do Until strFileName = vbNullString
strUser = Mid$(strFileName, 11, Len(strFileName) - 14)
Open strPath & strFileName For Random Access _
Read As #intFileNumber Len = Len(udtDataset)
Do
Get #intFileNumber, , udtDataset
If EOF(intFileNumber) Then Exit Do
lngRow = lngRow + 1
.Cells(lngRow, 1).Value = strUser
.Cells(lngRow, 2).Value = Trim$(udtDataset.strSearchTerm)
.Cells(lngRow, 3).Value = udtDataset.lngCount
Loop
Close #intFileNumber
strFileName = Dir$
Loop
.UsedRange.EntireColumn.AutoFit
End With
End Sub
Gruß
Nepumuk