All,
How can I modify the code below to not just grab the first table of each word document in a specific folder but to extract all of the tables from each document? I've tried manipulating the code myself but I can't seem to get it right. Any help would be greatly appreciated.
Option Explicit
Sub test()
Dim oWord As Word.Application
Dim oDoc As Word.Document
Dim oCell As Word.Cell
Dim sPath As String
Dim sFile As String
Dim r As Long
Dim c As Long
Dim Cnt As Long
Application.ScreenUpdating = False
Set oWord = CreateObject("Word.Application")
sPath = "C:\Users\Domenic\Desktop\" 'change the path accordingly
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sFile = Dir(sPath & "*.doc")
r = 2 'starting row
c = 1 'starting column
Cnt = 0
Do While Len(sFile) > 0
Cnt = Cnt + 1
Set oDoc = oWord.Documents.Open(sPath & sFile)
For Each oCell In oDoc.Tables(1).Range.Cells
Cells(r, c).Value = Replace(oCell.Range.Text, Chr(13) & Chr(7), "")
c = c + 1
Next oCell
oDoc.Close savechanges:=False
r = r + 1
c = 1
sFile = Dir
Loop
Application.ScreenUpdating = True
If Cnt = 0 Then
MsgBox "No Word documents were found...", vbExclamation
End If
End Sub
Dim tbl
'........
Set oDoc = oWord.Documents.Open(sPath & sFile)
For each tbl in oDoc.Tables
For Each oCell In tbl.Range.Cells
Cells(r, c).Value = Replace(oCell.Range.Text, Chr(13) & Chr(7), "")
c = c + 1
Next oCell
r = r + 2 'couple of blank rows between tables
c = 1
Next tbl
oDoc.Close savechanges:=False
'.........
Related
I have to write a script that parses the images from ppt and dumps into excel. To do this, I first export all the images in the slides to a folder and then call excel Application to import them into the worksheet. The following code, which I found online, with my modifications is as follows:
Sub ExtractImagesFromPres()
Dim oSldSource As Slide
Dim oShpSource As Shape
Dim Ctr As Integer
Dim ObjExcel As Object
Dim wb As Object
Dim ws As Object
Set ObjExcel = CreateObject("Excel.Application")
Dim sPath As String
sPath = "C:\Users\Aravind_Sampathkumar\Documents\Expor"
Ctr = 0
Set wb = ObjExcel.Workbooks.Open("C:\Users\Aravind_Sampathkumar\Documents\Book1.xlsx")
Set ws = wb.Sheets(1)
'Open oPres.Path & PathSep & "Book1.CSV" For Output As iFile
For Each oSldSource In ActivePresentation.Slides
For Each oShpSource In oSldSource.Shapes
If oShpSource.Type = msoPicture Then
' Hidden Export method
Call oShpSource.Export(sPath & "Img" & Format(Ctr, "0000") & ".JPG", ppShapeFormatJPG)
Ctr = Ctr + 1
End If
Next oShpSource
Next oSldSource
Folderpath = "C:\Users\Aravind_Sampathkumar\Documents\Expor"
Set fso = CreateObject("Scripting.FileSystemObject")
NoOfFiles = fso.GetFolder(Folderpath).Files.Count
Set listfiles = fso.GetFolder(Folderpath).Files
counter = 1
For Each fls In listfiles
strCompFilePath = Folderpath & "\" & Trim(fls.Name)
If strCompFilePath <> "" Then
If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
counter = counter + 1
' ws.Range("C" & counter).Value = fls.Name
ws.Range("D" & counter).ColumnWidth = 25
ws.Range("D" & counter).RowHeight = 100
ws.Range("D" & counter).Activate
'Call insert(strCompFilePath, counter)
ws.Shapes.AddPicture strCompFilePath, True, True, 100,100,70,70
End If
End If
Next
'ws.Shapes.AddPicture ("C:\Users\Aravind_Sampathkumar\Documents")
'With .ShapeRange
' .LockAspectRatio = msoTrue
' .Width = 100
'.Height = 100
'End With
' .Left = ws.Cells(i, 20).Left
'.Top = ws.Cells(i, 20).Top
'.Placement = 1
'.PrintObject = True
'End With
End Sub
When I run it, the images get dumped into excel but all the images are overlapped on each other in the same cell. Is there any way I can modify it such that images go into consecutive rows? 1 image per row?
This puts them a row apart but you would need to size them appropriately. Note I changed your paths for test paths.
Option Explicit
Sub ExtractImagesFromPres()
Dim oSldSource As Slide
Dim oShpSource As Shape
Dim Ctr As Integer
Dim ObjExcel As Object
Dim wb As Object
Dim ws As Object
Set ObjExcel = CreateObject("Excel.Application")
Dim sPath As String
sPath = "C:\Users\User\Desktop\TestFolder" '"C:\Users\Aravind_Sampathkumar\Documents\Expor"
Ctr = 0
Set wb = ObjExcel.Workbooks.Open("C:\Users\User\Desktop\TestFolder\Test.xlsx") '("C:\Users\Aravind_Sampathkumar\Documents\Book1.xlsx")
ObjExcel.Visible = True
Set ws = wb.Sheets(1)
For Each oSldSource In ActivePresentation.Slides
For Each oShpSource In oSldSource.Shapes
If oShpSource.Type = msoPicture Then
Call oShpSource.Export(sPath & "\" & "Img" & Format(Ctr, "0000") & ".JPG", ppShapeFormatJPG)
Ctr = Ctr + 1
End If
Next oShpSource
Next oSldSource
Dim Folderpath As String
Dim fso As Object
Dim NoOfFiles As Long
Dim listfiles As Object
Dim counter As Long
Dim fls As Variant
Dim strCompFilePath As String
Folderpath = "C:\Users\User\Desktop\TestFolder" '"C:\Users\Aravind_Sampathkumar\Documents\Expor"
Set fso = CreateObject("Scripting.FileSystemObject")
NoOfFiles = fso.GetFolder(Folderpath).Files.Count
Set listfiles = fso.GetFolder(Folderpath).Files
counter = 1
For Each fls In listfiles
strCompFilePath = Folderpath & "\" & Trim(fls.Name)
If strCompFilePath <> vbNullString Then
If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
counter = counter + 1
' ws.Range("C" & counter).Value = fls.Name
ws.Range("D" & counter).ColumnWidth = 25
ws.Range("D" & counter).RowHeight = 100
ws.Range("D" & counter).Activate
'Call insert(strCompFilePath, counter)
With ws.Pictures.Insert(strCompFilePath)
.Left = ws.Cells(counter, "D").Left
.Top = ws.Cells(counter, "D").Top
End With
End If
End If
Next
End Sub
Have a look at the documentation for the AddPicture method:
https://msdn.microsoft.com/en-us/vba/excel-vba/articles/shapes-addpicture-method-excel
expression.AddPicture(Filename, LinkToFile, SaveWithDocument, Left, Top, Width, Height)
Rather than adding the picture at the active cell, it's location is controlled by the Left and Top arguments. You can use the Left and Top properties of the target cell as the arguments of the AddPicture method:
ws.Shapes.AddPicture strCompFilePath, True, True, ws.Range("D" & counter).Left, ws.Range("D" & counter).Top,70,70
Here's a version that uses copy/paste instead of export/import - it does include the line to change the row height if you want to crib just that.. :P
Sub ExtractImagesFromPres()
Dim oSldSource As Slide
Dim oShpSource As Shape
Dim ObjExcel As Object
Dim wb As Object
Dim ws As Object
Set ObjExcel = CreateObject("Excel.Application")
Dim lOffset AS Long
Set wb = ObjExcel.Workbooks.Open("C:\Users\Aravind_Sampathkumar\Documents\Book1.xlsx")
Set ws = wb.Sheets(1)
'Open oPres.Path & PathSep & "Book1.CSV" For Output As iFile
lOffset = 5
For Each oSldSource In ActivePresentation.Slides
For Each oShpSource In oSldSource.Shapes
If oShpSource.Type = msoPicture Then
oShpSource.Copy
ws.Paste
With ws.Shapes(ws.Shapes.Count)
.Top = lOffset
.Left = 5
.Placement = 3 'xlFreeFloating
'This line sets the row height!
.TopLeftCell.EntireRow.RowHeight = 10 + .Height
lOffset = lOffset + .Height + 10
End With
End If
Next oShpSource
Next oSldSource
'Optional Tidy-Up code
'Set ws = Nothing
'wb.Save
'Set wb = Nothing
'ObjExcel.Quit
'Set ObjExcel = Nothing
End Sub
I'm 100% certain you can export the images from PPT directly to XLS, but I'm not really sure how to do that. However, since you are able to export those images from PPT into a folder, and you just need help importing the images from there, I thin the code below will do just what you want.
Sub InsertPics()
Dim fPath As String, fName As String
Dim r As Range, rng As Range
Application.ScreenUpdating = False
fPath = "C:\your_path_here\"
Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
i = 1
For Each r In rng
fName = Dir(fPath)
Do While fName <> ""
If fName = r.Value Then
With ActiveSheet.Pictures.Insert(fPath & fName)
.ShapeRange.LockAspectRatio = msoTrue
Set px = .ShapeRange
If .ShapeRange.Width > Rows(i).Columns(2).Width Then .ShapeRange.Width = Columns(2).Width
With Cells(i, 2)
px.Top = .Top
px.Left = .Left
.RowHeight = px.Height
End With
End With
End If
fName = Dir
Loop
i = i + 1
Next r
Application.ScreenUpdating = True
End Sub
' Note: you need the file extension, such as ',jpg', or whatever you are using, so you can match on that.
Sub Insert()
Dim strFolder As String
Dim strFileName As String
Dim objPic As Picture
Dim rngCell As Range
strFolder = "C:\Users\Public\Pictures\Sample Pictures\" 'change the path accordingly
If Right(strFolder, 1) <> "\" Then
strFolder = strFolder & "\"
End If
Set rngCell = Range("E1") 'starting cell
strFileName = Dir(strFolder & "*.jpg", vbNormal) 'filter for .png files
Do While Len(strFileName) > 0
Set objPic = ActiveSheet.Pictures.Insert(strFolder & strFileName)
With objPic
.Left = rngCell.Left
.Top = rngCell.Top
.Height = rngCell.RowHeight
.Placement = xlMoveAndSize
End With
Set rngCell = rngCell.Offset(1, 0)
strFileName = Dir
Loop
End Sub
I get a
Type Mismatch Error "13"
with the below code. Can anyone assist with where I'm going wrong with my VBA syntax and use of variables.
If Application.WorksheetFuntion.CountIf(Target, r.Value) > 1 Then
I've tried the matchFoundIndex code method to no success...Likely due to incorrect VBA syntax.
The intent of the CountIf line is to look for duplicates in column A. The rest of the code loops through files and worksheets copying the file name, worksheet name, and cell C1 for further analysis. I am a novice at coding and I'm sure there may be Dimmed variables that I'm not using, other formatting, and errors that I have not found yet. Any Help would be appreciative.
Sub CopyFileAndStudyName()
Dim sPath As String, SName As String
Dim xlWB As Workbook
Dim sh As Worksheet
Dim lngRow As Long
Dim lngwsh As Long
Dim xlApp As Excel.Application
Dim sfile As String
Dim wbk As Workbook
Dim iCntr As Long
Dim matchFoundIndex As Long
Dim FindDuplicates As Boolean
Dim IsDup As Boolean
sPath = "C:\Users\mypath\"
' which row to begin writing to in the activesheet
lngRow = 2
SName = Dir(sPath & "*.xlsx") ' for xl2007 & "*.xls"
Set xlApp = New Excel.Application
xlApp.Visible = False
If MsgBox("Are you sure you want to copy all the file and Cell C1 in " & sPath & "?", vbYesNo) = vbNo Then Exit Sub
Do While SName <> ""
lngwsh = 1
' Will cycle through all .xlsx files in sPath
Set xlWB = xlApp.Workbooks.Open(sPath & SName, , True) ' opens in read-only mode
' Will cycle through first 3 of the worksheets in each file copying file name and cell C1 in columns C and D
For lngwsh = 1 To 3
Set sh = ActiveSheet
sh.Cells(lngRow, "A") = xlWB.Name
sh.Cells(lngRow, "B") = xlWB.Worksheets(lngwsh).Range("C1")
sh.Cells(lngRow, "C") = xlWB.Sheets(lngwsh).Name
Dim Target As Range
Dim r As Range
Dim lastRow As Long
Dim ws As Worksheet
Set ws = xlWB.Worksheets(lngwsh)
With ws
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Target = ws.Range("A1:A" & lastRow)
End With
For Each r In Target
If r.Value <> "" Then
If Application.WorksheetFunction.CountIf(Target, r.Value) > 1 Then
FindDuplicates = True
Exit For
Else
FindDuplicates = False
End If
End If
Next r
Debug.Print FindDuplicates
IsDup = FindDuplicates
sh.Cells(lngRow, "D") = IsDup
FindDuplicates = False
End If
lngRow = lngRow + 1
Next lngwsh
xlWB.Close False
xlApp.Quit
SName = Dir()
Loop
MsgBox "Report Ready!"
End Sub
If you want to check for Duplicates in a Range, you can use a Dictionary object.
Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
For Each r In Target
If Trim(r.Value) <> "" Then
If Not Dict.exists(r.Value) Then ' not found in dictionary >> add Key
Dict.Add r.Value, r.Value
FindDuplicates = False
Else ' found in Dictionary >> Exit
FindDuplicates = True
Exit For
nd If
End If
Next r
Sub CopyFileAndStudyName()
Dim sPath As String, SName As String
Dim xlWB As Workbook
Dim sh As Worksheet
Dim lngRow As Long
Dim lngwsh As Long
Dim xlApp As Excel.Application
Dim sfile As String
Dim wbk As Workbook
Dim iCntr As Long
Dim matchFoundIndex As Long
Dim FindDuplicates As Boolean
Dim IsDup As Boolean
sPath = "C:\Users\mypath\"
' which row to begin writing to in the activesheet
lngRow = 2
SName = Dir(sPath & "*.xlsx") ' for xl2007 & "*.xls"
Set xlApp = New Excel.Application
xlApp.Visible = False
If MsgBox("Are you sure you want to copy all the file and Cell C1 in " & sPath & "?", vbYesNo) = vbNo Then Exit Sub
Do While SName <> ""
lngwsh = 1
' Will cycle through all .xlsx files in sPath
Set xlWB = xlApp.Workbooks.Open(sPath & SName, , True) ' opens in read-only mode
' Will cycle through first 3 of the worksheets in each file copying file name and cell C1 in columns C and D
For lngwsh = 1 To 3
Set sh = ActiveSheet
sh.Cells(lngRow, "A") = xlWB.Name
sh.Cells(lngRow, "B") = xlWB.Worksheets(lngwsh).Range("C1")
sh.Cells(lngRow, "C") = xlWB.Sheets(lngwsh).Name
Dim Target As Range
Dim r As Range
Dim lastRow As Long
Dim ws As Worksheet
Set ws = xlWB.Worksheets(lngwsh)
With ws
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Target = ws.Range("A1:A" & lastRow)
End With
For Each r In Target
If r.Value <> "" Then
If Application.WorksheetFunction.CountIf(Target, r.Value) > 1 Then
FindDuplicates = True
Exit For
Else
FindDuplicates = False
End If
End If
Next r
Debug.Print FindDuplicates
IsDup = FindDuplicates
sh.Cells(lngRow, "D") = IsDup
FindDuplicates = False
lngRow = lngRow + 1
Next lngwsh
xlWB.Close False
xlApp.Quit
SName = Dir()
Loop
MsgBox "Report Ready!"
End Sub
I was having a similar experience using CountIF and passing it a range. In my case I was using:
i = Application.WorksheetFunction.CountIf(ws.UsedRange, r.Value)
which was giving me a Type Mismatch error. I had seen other people having success with the first parameter wrapped in Range() so after a few tries I found out that this would work:
i = Application.WorksheetFunction.CountIf(Range(ws.UsedRange.Address), r.Value)
So, I suggest that you change your code to this and see if it works:
If Application.WorksheetFuntion.CountIf(Range(Target.Address), r.Value) > 1 Then
I've been following this site for years now and learned a lot from it, but this time I'm really stuck. So, time for me to finally register huh! :-)
At work, we have 19740 Word documents (no lie!) that need to be processed. It are all invoices. To make it more understandable, I uploaded a file, which can be found here: http://1drv.ms/1U7SsHH
All files have the same layout and structure. I marked everything that needs to get extracted in a color. I also need the filename of each Word document in the first Excel column.
The Excel file should look like something like this with its columns:
Filename
Factuurnummer (yellow)
Leerling (red)
Vervaldatum (green)
Datum (turquoise)
Algemeen Totaal (blue)
Mededeling (lilac)
Note: the cell marked blue isn't always the same. Here's an example of such file: http://1drv.ms/1U7SFLa
I found a script online, but it extracts everything in only the table and puts it all in one colomn.. It's been almost 7 years since I last wrote a VBA script, so I'm really rusty... /ashamed
I really hope that you guys can help me out here! Thanks in advance!
EDIT: forgot to place my current code here, sorry!
Sub omzetting()
Dim oWord As Word.Application
Dim oDoc As Word.Document
Dim oCell As Word.Cell
Dim sPath As String
Dim sFile As String
Dim r As Long
Dim c As Long
Dim Cnt As Long
Application.ScreenUpdating = False
Set oWord = CreateObject("Word.Application")
sPath = "C:\Users\Andy\Desktop\SGR14\edusoft\facturen\sgr14_all\kopie" 'pad waar de Edusoft Word bestanden staan
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sFile = Dir(sPath & "*.doc")
r = 1 'start rij
c = 1 'start kolom
Cnt = 0
Do While Len(sFile) > 0
Cnt = Cnt + 1
Set oDoc = oWord.Documents.Open(sPath & sFile)
For Each oCell In oDoc.Tables(1).Range.Cells
Cells(5, 6).Value = Replace(oCell.Range.Text, Chr(13) & Chr(7), "")
c = c + 1
Next oCell
oDoc.Close savechanges:=False
r = r + 1
c = 1
sFile = Dir
Loop
Application.ScreenUpdating = True
If Cnt = 0 Then
MsgBox "Geen Word documenten gevonden. Plaats dit Excel bestand in dezelfde map.", vbExclamation
End If
End Sub
I would
Read the invoice
Create a variant array that consists of only the relevant items, some of which will need to be processed so as to deal with ensuring the Dates are properly translated (VBA tends to be US-centric), and that we remove extraneous, non-printing characters
Collect each variant array as what will be a row into a collection
after processing all the files, write the row collection into a results array and write it to the worksheet.
EDIT: If you examine closely, you will find that totaal is in a particular cell in a subtable of the main table. So the processing can be shortened considerably.
I did not see anything "lilac", so I did not collect Mededeling, but you should be able to figure that out from the code I provided.
The code works on the two invoices you provided, but may need some work depending on the variability of your data.
I tried to keep most of your code.
Option Explicit
Sub omzetting()
Dim oWord As Word.Application
Dim oDoc As Word.Document
Dim sPath As String
Dim sFile As String
Dim oTbl As Word.Table
Dim colRow As Collection
Dim V(1 To 7) As Variant
Dim I As Long, J As Long
Dim vRes() As Variant
Dim rRes As Range
Set rRes = Cells(1, 1)
Set oWord = New Word.Application
Set colRow = New Collection
'Change sPath to reflect the folder in YOUR system
sPath = "d:\Users\Ron\Desktop\New Folder\" 'pad waar de Edusoft Word bestanden staan
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sFile = Dir(sPath & "*.doc")
Do While Len(sFile) > 0
Set oDoc = oWord.Documents.Open(sPath & sFile, ReadOnly:=True)
V(1) = sPath & sFile 'Filename
Set oTbl = oDoc.Tables(1)
With oTbl
With .Range
V(2) = .Cells(11).Range.Text 'Factuumummer (yellow)
V(3) = .Cells(6).Range.Text ' Leerling (red)
V(4) = .Cells(13).Range.Text 'Vervaldatum (green)
V(5) = .Cells(15).Range.Text 'Datum (turquoise)
End With
With oTbl.Tables(2).Range
V(6) = .Cells(3).Range.Text 'Algemeen Totaal (blue)
End With
'V(7) = wherever Mededeling is
End With
'Remove unneeded characters
For J = 1 To 7
V(J) = Replace(V(J), vbCr, "")
V(J) = Replace(V(J), vbLf, "")
V(J) = Replace(V(J), Chr(7), "")
Next J
'Process dates and values
V(4) = DateSerial(Right(V(4), 4), Mid(V(4), 4, 2), Left(V(4), 2))
V(5) = DateSerial(Right(V(5), 4), Mid(V(5), 4, 2), Left(V(5), 2))
'Add to collection
colRow.Add V
oDoc.Close savechanges:=False
sFile = Dir
Loop
If colRow.Count = 0 Then
MsgBox "Geen Word documenten gevonden. Plaats dit Excel bestand in dezelfde map.", vbExclamation
End If
'Set up and populate results array
'Could dim vRes(0 to ....) and use Row 0 for column labels
ReDim vRes(1 To colRow.Count, 1 To 6)
For I = 1 To UBound(vRes, 1)
For J = 1 To UBound(vRes, 2)
vRes(I, J) = colRow(I)(J)
Next J
Next I
'write results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
.EntireColumn.AutoFit
End With
End Sub
I'm trying to extract data (the information on the second column of word tables) from multiple word documents and compile the data to one excel (2011 mac version).
Below is the example:
the word table
the excel
I wrote a code, but this code doesn't work. How to revise this code so that it can work properly? thanks a lot!
Sub extractdata()
Dim r As Integer
Dim c As Integer
r = 1
c = 8
Range(Cells(r + 1, ”A”), Cells(65536, c)).ClearContents
Application.ScreenUpdating = False
Dim filename As String, wdapp As Object, erow As Long, fn As String, arr As Variant
Set wordapp = CreateObject("word.application")
filename = Dir(ThisWorkbook.Path & “ \ " & " * .docx”)
Do While filename <> “”
With wordapp.documents.Open(ThisWorkbook.Path & "\" & filename)
For i = 1 To 8
arr = Left(.Table(1).Cells(i, 2))
Next
Cells(erow, “A”).Resize(UBound(arr, 1), 8) = arr
End With
filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
Untested:
Sub extractdata()
Dim c As Long
c = 8
Range(Cells(r + 1, "A"), Cells(65536, c)).ClearContents
Application.ScreenUpdating = False
Dim filename As String, wdapp As Object, erow As Long, _
Dim fn As String, i as Long
Set wordapp = CreateObject("word.application")
filename = Dir(ThisWorkbook.Path & "\*.docx")
Do While filename <> ""
With wordapp.documents.Open(ThisWorkbook.Path & "\" & filename)
For i = 1 To c
Cells(erow, i) = Left(.Tables(1).Cell(i, 2)).Range.Text
Next
.Close False
End With
filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Given a folder tree:
c:\example\
c:\example\2014-01-01\
c:\example\2014-01-01\Entered\
c:\example\2014-01-02\
c:\example\2014-01-02\Entered
etc.
I want to count the PDF files in the tree, but excluding any in the "Entered\" subfolders.
Is this possible even with VBA? Ultimately this count needs to be spit out onto an excel sheet.
copy all the code in an Excel-VBA Module. If you want to use a button then you should use CntFiles() on the button. But if you don't want to use a button then you can use fCount(strPath) as a formula on the Worksheet i.e =fCount("your-path"), the parameter is String so make it double-quoted when using on Worksheet.
Function fCount(strPath)
Dim fCnt As Integer
fCnt = ShowFolderList(strPath)
fCount = fCnt
End Function
Sub CntFiles()
Dim strPath As String
strPath = "A:\Asif\Answers\abc"
ShowFolderList (strPath)
End Sub
Function ShowFolderList(Path)
Dim fso, folder, subFlds, fld
Dim tFiles As Integer
tFiles = ShowFilesList(Path)
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(Path)
Set subFlds = folder.SubFolders
For Each fld In subFlds
If fld.Name = "Entered" Then
GoTo SkipFld:
Else
Path = fld.Path
tFiles = tFiles + ShowFilesList(Path)
End If
SkipFld:
Next
'MsgBox tFiles & " files"
ShowFolderList = tFiles
End Function
Function ShowFilesList(folderspec)
Dim fso, f, f1, fc, s
Dim Cnt As Integer
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder(folderspec)
Set fc = f.Files
For Each f1 In fc
If GetAnExtension(f1) = "pdf" Then
Cnt = Cnt + 1
Else
End If
Next
ShowFilesList = Cnt
End Function
Function GetAnExtension(DriveSpec)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
GetAnExtension = fso.GetExtensionName(DriveSpec)
End Function
This code will count all the files in the specified folder as well as sub-folders excluding folder named "Entered" as you specified.
This code gives you a nice overview in an excel sheet:
Sub start()
Application.ScreenUpdating = False
Dim FolderName As String
Sheets("fldr").Select
Cells(1, 1).Value = 2
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
On Error Resume Next
FolderName = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
ListFolders (FolderName)
Application.ScreenUpdating = True
MsgBox "Done" & vbCrLf & "Total files found: " & Cells(1, 1).Value
Cells(1, 1).Value = "Source"
Cells(1, 2).Value = "Folder"
Cells(1, 3).Value = "Subfolder"
Cells(1, 4).Value = "FileCount"
End Sub
Sub ListFolders(Fldr As String)
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
Dim fl1
Set fl1 = CreateObject("Scripting.FileSystemObject")
Dim fl2
Set fl2 = CreateObject("Scripting.FileSystemObject")
Set fl1 = fs.GetFolder(Fldr)
For Each fl2 In fl1.SubFolders
Cells(Cells(1, 1).Value, 1).Value = Replace(Fldr, fl1.Name, "")
Cells(Cells(1, 1).Value, 2).Value = fl1.Name
Cells(Cells(1, 1).Value, 3).Value = fl2.Name
Cells(Cells(1, 1).Value, 4).Value = CountFiles(Fldr & "\" & fl2.Name)
Cells(1, 1).Value = Cells(1, 1).Value + 1
ListFolders fl2.Path
Next
End Sub
Function CountFiles(Fldr As String)
Dim fso As Object
Dim objFiles As Object
Dim obj As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFiles = fso.GetFolder(Fldr).Files
CountFiles = objFiles.Count
Set objFiles = Nothing
Set fso = Nothing
Set obj = Nothing
End Function