Scribd
Upload
4 views3 pages

Recurssive Linecnt

VBS script

Uploaded by

shrikant87sakhare
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
4 views3 pages

Recurssive Linecnt

VBS script

Uploaded by

shrikant87sakhare
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as TXT, PDF, TXT or read online on Scribd
You are on page 1/ 3

Private fso As New Scripting.

FileSystemObject
Public fldr As Scripting.Folder
Public sfldr As Scripting.Folder
Public strNames() As String
Public DSheet As Worksheet
Public m, n As Long
Sub processfiles(Pathtofolder As String)
Dim WSheet As Worksheet
Set fldr = fso.GetFolder(Pathtofolder)
Set WSheet = Worksheets("Data1")
Dim RSheet As Worksheet
Set RSheet = Worksheets("AllList")
Dim Data() As Byte
Dim text As String
With WSheet
Dim rw As Long: rw = WSheet.Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
Dim fileNumb As Long
fileNumb = FreeFile
Dim Line As Variant
Dim Lines As Variant
Dim key As Variant
Dim Keys As Variant
Dim word1 As String
Dim cnt As Long
Dim str As String
Dim Item1 As Scripting.File
For Each Item1 In fldr.Files
With RSheet
Dim rw1 As Long: rw1 = RSheet.Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
RSheet.Cells(rw1, 1).Value = fldr.Name
RSheet.Cells(rw1, 2).Value = Item1.Name
'rw1 = rw1 + 1
'MsgBox Item1.path
Open Item1.path For Binary Access Read As fileNumb
ReDim Data(LOF(fileNumb))
Get fileNumb, , Data
Close fileNumb
text = StrConv(Data, vbUnicode)
cnt = LineCount(Item1)
Dim x As Long
Lines = Split(text, vbCrLf)
For x = 0 To UBound(Lines)
Line = Trim(Lines(x))
If Line <> "" Then
For i = 0 To n
strNames(i) = DSheet.Range("A1").Offset(i + 1, 0)
'MsgBox strNames(i)
Dim regex As Object

Set regex = CreateObject("Vbscript.regexp")


With regex
.IgnoreCase = Not blnCaseSensitive
.MultiLine = True
.pattern = strNames(i)
.Global = True
End With
If Left(Line, Len(strNames(i))) = strNames(i) Then
If regex.test(Line) Then
For Each Match In regex.Execute(Line)
word1 = CStr(Line)
Dim vData As Variant
vData = Split(word1 & " ", " ")
WSheet.Cells(rw, 1).Value = fldr.Name
WSheet.Cells(rw, 2).Value = Item1.Name
WSheet.Cells(rw, 3).Value = strNames(i)
WSheet.Cells(rw, 4).Value = Line
WSheet.Cells(rw, 5).Value = Trim(vData(0) & " " & vData(1))
WSheet.Cells(rw, 6).Value = cnt
rw = rw + 1
Next
End If
End If
Next i
End If
Next x

Next Item1

For Each sfldr In fldr.SubFolders


processfiles sfldr.path
Next sfldr

End Sub

Sub Recursive()

On Error Resume Next


Application.DisplayAlerts = False
Worksheets("Data1").delete
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "Data1"
Application.DisplayAlerts = True

Application.DisplayAlerts = False
Worksheets("AllList").delete
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "AllList"
Application.DisplayAlerts = True

Set DSheet = Worksheets("Inputs")


Dim Row As Long
Dim i As Long
m = DSheet.Range("A1", DSheet.Range("A1").End(xlDown)).Rows.Count
n = m - 2
ReDim strNames(n)
Dim WSheet As Worksheet
Set WSheet = Worksheets("Data1")
WSheet.Range("A1").Value = "Program_Folder"
WSheet.Range("B1").Value = "Program_List"
WSheet.Range("C1").Value = "Keylabel"
WSheet.Range("D1").Value = "Types"
WSheet.Range("E1").Value = "Proc_macro_name"
WSheet.Range("F1").Value = "Number_of_Lines"
Dim RSheet As Worksheet
Set RSheet = Worksheets("AllList")
RSheet.Range("A1").Value = "Program_Folder"
RSheet.Range("B1").Value = "Program_List"

processfiles ("C:\Users\70415\Documents\Euroclear\Second")

Columns("B").Replace What:="%", Replacement:="%Macro"


End Sub

Function LineCount(flname As Scripting.File) As Long


Open flname For Input As #1
'Do While Not EOF(1)
Do Until EOF(1)
Line Input #1, D
If Trim(D) <> vbNullString Then
i = i + 1
End If
Loop
Close #1
LineCount = i
End Function

You might also like