Hey everyone I found this awesome code that helped me get the loop I needed but I am trying to alter this to extract all the data from the word tables not just one row of the tables.. Any help would be great. I know it going to be a simple fix just haven't been able to get any to work on my own. Thanks
Sub wordScrape()
Dim wrdDoc As Object, objFiles As Object, fso As Object, wordApp As Object
Dim sh1 As Worksheet
Dim x As Integer
FolderName = "C:\code" ' Change this to the folder containing your word documents
Set sh1 = ThisWorkbook.Sheets(1)
Set fso = CreateObject("Scripting.FileSystemObject")
Set wordApp = CreateObject("Word.application")
Set objFiles = fso.GetFolder(FolderName).Files
x = 1
For Each wd In objFiles
If InStr(wd, ".docx") And InStr(wd, "~") = 0 Then
Set wrdDoc = wordApp.Documents.Open(wd.Path, ReadOnly = True)
sh1.Cells(x, 1) = wd.Name
sh1.Cells(x, 2) = Application.WorksheetFunction.Clean(wrdDoc.Tables(3).Cell(Row:=3, Column:=2).Range)
'sh1.Cells(x, 3) = ....more extracted data....
x = x + 1
wrdDoc.Close
End If
Next wd
wordApp.Quit
End Sub`
Sub wordScrape()
Dim wd As New Word.Application
Dim wdDoc As Word.Document
Dim tbl As Word.Table
Dim sh1 As Worksheet
Dim x As Integer
Dim y As Integer
Dim s As String
Dim r As Range
FolderName = "C:\code" ' Change this to the folder containing your word documents
Set sh1 = ThisWorkbook.Sheets(1)
Set r = sh1.Range("a1")
s = Dir(FolderName & "\*.doc*")
Do While s <> ""
If InStr(wd, "~") = 0 Then
Set wdDoc = wd.Documents.Open(FolderName & "\" & s, False, True, False)
For Each tbl In wdDoc.Tables
For x = 1 To t.Rows.Count
r = wdDoc.Name
For y = 1 To t.Columns.Count
r.Offset(0, y) = Application.WorksheetFunction.Clean(t.Cell(Row:=x, Column:=y).Range)
Next y
Set r = r.Offset(1, 0)
Next x
Next tbl
wdDoc.Close False
End If
s = Dir()
Loop
End Sub
Now, this is off the top of my head, it assumes a reference to word is set (tools,references in the VBE) and it crucially assumes that every table has no merged cells - if they do it will break. But it gets you started
Related
I am trying to pull data from a folder containing 300 Workbooks, each named 001, 002 etc.
I am only interested in pulling the data from column G of each file and copying it into a separate folder (each file does not have the same amount if data in row G)
I have been able to copy the data across, but I can't seem to get it to move past column 2 and instead writes over the previous column.
The output needed is:
data from column G workbook"001" pasted into "new sheet" column A
data from column G workbook"002" pasted into "new sheet" column B
and so on
Each file in the folder of 300 only has 1 worksheet each, each labelled: 001,002,...,300
This is the code I already had which results in 2 columns of data where 1 gets replaced by each new sheet instead.
Any help to solve this issue would be greatly appreciated.
Sub Copy()
Dim MyFile As String
Dim Filepath As String
Dim q As Long
Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer
Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1
Filepath = "C:..."
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Text to column.xlsm" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
LastRow = Range("G1").CurrentRegion.Rows.Count
Range("G1", Range("G" & LastRow)).Copy ThisWorkbook.Sheets("Sheet1").Range(CurS.Cells(ThisRow, ThisCol + 1), CurS.Cells(ThisRow, ThisCol + CurS.Cells(ThisRow, InfCol).Value))
ActiveWorkbook.Save
ActiveWorkbook.Close
MyFile = Dir
Loop
End Sub
To properly copy in a new column each time, you need a variable that increments during each loop to offset by one each time. When you use ThisCol + 1 you're always getting the same value because ThisCol is not updated.
Something like this:
Sub Copy()
Dim MyFile As String
Dim Filepath As String
Dim q As Long
Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer
Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1
Filepath = ReplacewithyouFilePath
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Text to column.xlsm" Then
Exit Sub
End If
'Let's keep a reference to the workbook
Dim wb As Workbook
Set wb = Workbooks.Open(Filepath & MyFile)
'Let's keep a reference to the first sheet where the data is
Dim ws As Worksheet
Set ws = wb.Sheets(1)
Dim LastRow As Long
LastRow = ws.Range("G1").CurrentRegion.Rows.Count
'We create a variable to increment at each column
Dim Counter As Long
'Let's make the copy operation using the Counter
ws.Range("G1", ws.Range("G" & LastRow)).Copy CurS.Range(CurS.Cells(ThisRow, ThisCol + Counter), CurS.Cells(ThisRow + LastRow - 1, ThisCol + Counter))
'We increment the counter for the next file
Counter = Counter + 1
'We use wb to make sure we are referring to the right workbook
wb.Save
wb.Close
MyFile = Dir
'We free the variables for good measure
Set wb = Nothing
Set ws = Nothing
Loop
End Sub
Import Columns
Sub ImportColumns()
Const FOLDER_PATH As String = "C:\Test"
Const FILE_EXTENSION_PATTERN As String = "*.xls*"
Const SOURCE_WORKSHEET_ID As Variant = 1
Const SOURCE_COLUMN As String = "G"
Const SOURCE_FIRST_ROW As Long = 1
Const DESTINATION_WORKSHEET_NAME As String = "Sheet1"
Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
Const DESTINATION_COLUMN_OFFSET As Long = 1
Dim pSep As String: pSep = Application.PathSeparator
Dim FolderPath As String: FolderPath = FOLDER_PATH
If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
Dim DirPattern As String: DirPattern = FolderPath & FILE_EXTENSION_PATTERN
Dim SourceFileName As String: SourceFileName = Dir(DirPattern)
If Len(SourceFileName) = 0 Then
MsgBox "No files found.", vbExclamation
Exit Sub
End If
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets(DESTINATION_WORKSHEET_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
Application.ScreenUpdating = False
Dim swb As Workbook
Dim sws As Worksheet
Dim srg As Range
Dim sfCell As Range
Dim slCell As Range
Do While Len(SourceFileName) > 0
If StrComp(SourceFileName, "Text to column.xlsm", vbTextCompare) _
<> 0 Then ' Why 'Exit Sub'? Is this the destination file?
Set swb = Workbooks.Open(FolderPath & SourceFileName, True, True)
Set sws = swb.Worksheets(SOURCE_WORKSHEET_ID)
Set sfCell = sws.Cells(SOURCE_FIRST_ROW, SOURCE_COLUMN)
Set slCell = sws.Cells(sws.Rows.Count, SOURCE_COLUMN).End(xlUp)
Set srg = sws.Range(sfCell, slCell)
srg.Copy dfCell
' Or, if you only need values without formulas and formats,
' instead, use the more efficient:
'dfCell.Resize(srg.Rows.Count).Value = srg.Value
Set dfCell = dfCell.Offset(, DESTINATION_COLUMN_OFFSET) ' next col.
swb.Close SaveChanges:=False ' we are just reading, no need to save!
'Else ' it's "Text to column.xlsm"; do nothing
End If
SourceFileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Columns imported.", vbInformation
End Sub
Thank you in advance, I need help in completing the below code, the code currently works to add the number of rows in the Table(3) of my word template as per the available rows in excel table, the word template have one row to begin with.
How can I pass the value from excel table range Set Rng = wsSheet.Range("A2:C" & lastrow)
Option Explicit
Sub CopyToWordTemplate()
Const stWordDocument As String = "TemplateSD.docm"
Dim intNoOfRows
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim lRow, i, lastrow, lastcol As Long
Dim vaData As Variant
Dim Rng As Range
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Transmittal")
lastrow = wsSheet.Range("A2").End(xlDown).Row
lastcol = wsSheet.Range("C2").End(xlToRight).Column
Set Rng = wsSheet.Range("A2:C" & lastrow)
Rng.ClearContents
Copy_Criteria_Text
lRow = wsSheet.Range("A2").End(xlDown).Row
intNoOfRows = lRow - 1
Set objWord = New Word.Application
objWord.Visible = True
Set objDoc = objWord.Documents.Open("\\Dn71\dn071\DOCUMENT CONTROL\Common\X-
Templates\Document Control\" & stWordDocument)
With objWord.ActiveDocument
.Bookmarks("Description").Range.Text = wsSheet.Range("D1").Value
.Bookmarks("RevNumber").Range.Text = "C" & wsSheet.Range("E1").Value
.Bookmarks("SubmittalNumber").Range.Text = "DN071-P02-CRC-GEN-PMT-SDA-" & wsSheet.Range("F1").Value
End With
For i = 2 To intNoOfRows
objDoc.Tables(3).Rows.Add
Next
Set objWord = Nothing
End Sub
I have the code below to copy an array of tables in Word to Excel. The volume of data being copied gives memory problems, so I would like to avoid the clipboard - i.e. avoid using Range.Copy
Word does not support Range.Value and I have not been able to get Range(x) = Range(y) to work.
Any suggestions for a way to avoid the clipboard? Word formatting can be junked.
Sub ImportWordTableArray()
Dim WordApp As Object
Dim WordDoc As Object
Dim arrFileList As Variant, FileName As Variant
Dim tableNo As Integer 'table number in Word
Dim tableStart As Integer
Dim tableTot As Integer
Dim Target As Range
On Error Resume Next
arrFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
"Browse for file containing table to be imported", , True)
If Not IsArray(arrFileList) Then Exit Sub
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Worksheets("Test").Range("A:AZ").ClearContents
Set Target = Worksheets("Test").Range("A1")
For Each FileName In arrFileList
Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
With WordDoc
'For array
Dim tables() As Variant
Dim tableCounter As Long
tableNo = WordDoc.tables.Count
tableTot = WordDoc.tables.Count
If tableNo = 0 Then
MsgBox WordDoc.Name & "Contains no tables", vbExclamation, "Import Word Table"
End If
tables = Array(1, 3, 5) '<- define array manually here if not using InputBox
For tableCounter = LBound(tables) To UBound(tables)
With .tables(tables(tableCounter))
.Range.Copy
Target.Activate
'Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False '<- memory problems!
'Or
ActiveSheet.Paste '<- pastes with formatting
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
Next tableCounter
.Close False
End With
Next FileName
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
You may need to tweak the code below to get it to do exactly what you want (Excel is not something I use often) as the calculation of ranges is a bit wonky, but it will transfer text from word to excel without cutting and pasting
Option Explicit
' This code is based on it being in an Excel VBA Module with the reference
' to the Microsoft Word Object XX.X Object Library (Tools.References)
' enabled so that we get intellisense for Word objects
Public Enum ImportError
NoTablesInDocument
End Enum
Sub ImportWordTableArray()
Dim myFileList As Variant
If Not TryGetFileList(myFileList) Then Exit Sub
Dim myWdApp As Word.Application
Set myWdApp = New Word.Application
myWdApp.Visible = True
If Application.ReferenceStyle = xlA1 Then Application.ReferenceStyle = xlR1C1
ThisWorkbook.Worksheets("Test").Range("A:AZ").ClearContents
Dim myFileName As Variant
For Each myFileName In myFileList
Dim myDoc As Word.Document
If TryGetWordDoc(myFileName, myWdApp, myDoc) Then
CopyDocTablesToExcel myDoc, ThisWorkbook.Worksheets("Test")
End If
Next
If Application.ReferenceStyle = xlR1C1 Then Application.ReferenceStyle = xlA1
End Sub
Public Sub CopyDocTablesToExcel(ByVal ipDoc As Word.Document, ByVal ipWs As Excel.Worksheet)
If ipDoc.Tables.Count = 0 Then
Report ipDoc.Name, ImportError.NoTablesInDocument
Exit Sub
End If
Dim myTable As Variant
Dim Target As Excel.Range
For Each myTable In ipDoc.Tables
' This code assumes that the Word table is 'uniform'
Dim myCols As Long
myCols = myTable.Range.Tables.Item(1).Range.Columns.Count
Dim myRows As Long
myRows = myTable.Range.Tables.Item(1).Range.Rows.Count
Dim myTLCell As Excel.Range
Dim myBRCell As Excel.Range
If Target Is Nothing Then
Set myTLCell = ipWs.Cells(1, 1)
Set myBRCell = ipWs.Cells(myCols, myRows)
Else
Set myTLCell = ipWs.Cells(1, Target.Cells.SpecialCells(xlCellTypeLastCell).Row + 2)
Set myBRCell = ipWs.Cells(myCols, Target.Cells.SpecialCells(xlCellTypeLastCell).Row + 2 + myRows)
End If
Set Target = ipWs.Range(myTLCell, myBRCell)
Target = GetTableArray(myTable)
Next
End Sub
Public Function GetTableArray(ByVal ipTable As Word.Table) As Variant
Dim myArray As Variant
Dim myRow As Long
Dim myCol As Long
ReDim myArray(1 To ipTable.Range.Tables.Item(1).Range.Rows.Count, 1 To ipTable.Range.Tables.Item(1).Range.Columns.Count)
For myRow = 1 To UBound(myArray, 1) - 1
For myCol = 1 To UBound(myArray, 2) - 1
Dim myText As String
myText = ipTable.Cell(myRow, myCol).Range.Text
myArray(myRow, myCol) = VBA.Left$(myText, Len(myText) - 2)
Next
Next
GetTableArray = myArray
End Function
Public Function TryGetFileList(ByRef opFileList As Variant) As Boolean
On Error Resume Next
opFileList = _
Application.GetOpenFilename _
( _
"Word files (*.doc; *.docx),*.doc;*.docx", _
2, _
"Browse for file containing table to be imported", _
, _
True _
)
TryGetFileList = (Err.Number = 0) And IsArray(opFileList)
On Error GoTo 0
End Function
Public Function TryGetWordDoc _
( _
ByVal ipName As String, _
ByRef ipWdApp As Word.Application, _
ByRef opDoc As Word.Document _
) As Boolean
On Error Resume Next
Set opDoc = ipWdApp.Documents.Open(ipName, ReadOnly:=True)
TryGetWordDoc = (Err.Number = 0) And (Not opDoc Is Nothing)
On Error GoTo 0
End Function
Public Function Report(ByVal ipString As String, ByVal ipError As ImportError)
Select Case ipError
Case NoTablesInDocument
MsgBox ipString & " Contains no tables", vbExclamation, "Import Word Table"
Case Else
End Select
End Function
For tableCounter ... Next code modified below to extract data directly rather than using copy and paste.
Sub ImportWordTablesArray()
Dim WordApp As Object
Dim WordDoc As Object
Dim arrFileList As Variant, Filename As Variant
Dim tableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim resultRow As Long
Dim tables() As Variant
Dim tableCounter As Long
On Error Resume Next
arrFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
"Browse for file containing table to be imported", , True)
If Not IsArray(arrFileList) Then Exit Sub '<-user cancelled import file browser
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Worksheets("Test").Range("A:E").Clear '<-ClearContents to clear only text
For Each Filename In arrFileList
Set WordDoc = WordApp.Documents.Open(Filename, ReadOnly:=True)
With WordDoc
If WordDoc.ProtectionType <> wdNoProtection Then
WordDoc.Unprotect Password:=SREPedit
End If
tableNo = WordDoc.tables.Count
If tableNo = 0 Then
MsgBox WordDoc.Name & "Contains no tables", vbExclamation, "Import Word Table"
End If
tables = Array(1, 2, 8) '<- Select tables for data extraction
For tableCounter = LBound(tables) To UBound(tables)
With .tables(tables(tableCounter))
For iRow = 1 To .Rows.Count
For iCol = 1 To .Columns.Count
Cells(resultRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
Next iCol
resultRow = resultRow + 1
Next iRow
End With
resultRow = resultRow + 1
Next tableCounter
.Close False
End With
Next Filename
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
I am trying to include a line in an Excel VBA script which identified all the text in a sentence that appears after the occurance of "Keyword:" in the body of multiple emails and copies each comma separated word into separate Excel cells. The phrases could be anything, always a single word but can't be predefined. For example, the email contained a line like:
Keyword: phrase1, phrase2, phrase3, phrase4
The result, in Excel:
First email: A1 phrase1 B1 phrase2 etc.
Second email: A2 phrase1 B2 phrase2 etc.
I've tried to use something like the following but don't know where to go from there:
CreateObject("VBScript.RegExp").Pattern = "((Keyword:)\s*(\w*),\s*(\w*),\s*(\w*),\s*(\w*),\s*(\w*))"
Here's what I have so far:
Option Compare Text
Sub Count_Emails()
Dim oNS As Outlook.Namespace
Dim oTaskFolder As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim oFoldToSearch As Object
Dim intCounter As Integer
Dim oWS As Worksheet
Dim dStartDate, dEnddate As Date
Set oWS = Sheets("Sheet1")
Set oNS = GetNamespace("MAPI")
Set oTaskFolder = oNS.Folders("bill.gates#microsoft.com")
Set oFoldToSearch = oTaskFolder.Folders("Inbox").Folders("New Folder")
Set oItems = oFoldToSearch.Items
intCounter = 1
dStartDate = oWS.Range("A1").Value
dEnddate = oWS.Range("B1").Value
Do
With oWS
If DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) >= dStartDate And _
DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) <= dEnddate And _
oItems(intCounter).Subject Like "*Keyword:*" Then
'Something needs to happen here? A VBScript.RegExp.Pattern maybe?
End If
End With
intCounter = intCounter + 1
Loop Until intCounter >= oItems.Count + 1
Set oNS = Nothing
Set oTaskFolder = Nothing
Set oItems = Nothing
End Sub
EDIT: To clarify that the phrases are not pre-defined, they could be anything.
EDIT2: To clarify that the body of the emails contains "Keyword:" followed by comma separated single words that are to be copied each into their own Excel cell.
Here I iterate over an array of phrases using instr to find the position of the phase in the mail item's subject. If the position in greater then 0 I use it to calculate the potion of the subject to write to the worksheet.
Count_Emails uses a ParamArray to accept up to 29 arguments in VBA 2003 or earlier and up to 60 arguments in VBA 2007 or later.
For Example if you only wanted to search for a single phrase:
NumberOfEmails = Count_Emails( "Phrase1" )
On the other hand if your had three phrases you need to search for, just add them as additional arguments
NumberOfEmails = Count_Emails( "Phrase1", "Phrase2", "Phrase3" )
Option Explicit
Option Compare Text
Function Count_Emails(ParamArray Phrases())
Dim Count as Long
Dim oNS As Outlook.Namespace
Dim oTaskFolder As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim phrase As Variant
Dim item As Object, oFoldToSearch As Object
Dim StartDate, EndDate As Date, MailDate As Date
Dim PhraseSize As Long, pos As Long
Set oNS = GetNamespace("MAPI")
Set oTaskFolder = oNS.Folders("bill.gates#microsoft.com")
Set oFoldToSearch = oTaskFolder.Folders("Inbox").Folders("New Folder")
Set oItems = oFoldToSearch.Items
With Sheets("Sheet1")
StartDate = .Range("A1").Value
EndDate = .Range("B1").Value
For Each item In oItems
MailDate = DateValue(item.ReceivedTime)
If MailDate >= StartDate And MailDate <= EndDate Then
For Each phrase In Phrases
pos = InStr(item.Subject, phrase)
If pos > 0 Then
With .Range("C" & Rows.Count).End(xlUp).Offset(1)
PhraseSize = Len(phrase)
.Value = Right(item.Subject, Len(item.Subject) - pos - PhraseSize + 1)
End With
Count = Count + 1
Exit For
End If
Next
End If
Next
End With
Set oNS = Nothing
Set oTaskFolder = Nothing
Set oItems = Nothing
Count_Emails = Count
End Function
Sub ExtractKeyWords(text As String)
Dim loc As Long
Dim s As String
Dim KeyWords
Dim Target As Range
loc = InStr(text, "Keyword:")
If loc > 0 Then
s = Trim(Right(text, Len(text) - loc - Len("Keyword:") + 1))
KeyWords = Split(s, ",")
With Worksheets("Sheet1")
If .Cells(1, .Columns.Count).End(xlToLeft) = "" Then
Set Target = .Cells(1, .Columns.Count).End(xlToLeft)
Else
Set Target = .Cells(1, .Columns.Count).End(xlToLeft).Offset(0, 1)
End If
Target.Resize(UBound(KeyWords) + 1).Value = Application.Transpose(KeyWords)
End With
End If
End Sub
if I correctly get your aim (see comments) you could modify your code as follows:
Option Explicit
Option Compare Text
Sub Count_Emails()
Dim oNS As Outlook.NameSpace
Dim oTaskFolder As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim keyword As Variant
Dim item As Object, oFoldToSearch As Object
Dim StartDate, EndDate As Date, MailDate As Date
Dim pos As Long
Dim xlApp As Excel.Application '<--| early binding ==> add your project the reference to Microsoft Excel XX.Y Object library
Dim phrasesArr As Variant
Set oNS = GetNamespace("MAPI")
Set oTaskFolder = oNS.Folders("bill.gates#microsoft.com")
Set oFoldToSearch = oTaskFolder.Folders("Inbox").Folders("New Folder")
Set oItems = oFoldToSearch.Items
Set xlApp = GetExcel(True) '<--| get running instance of excel application
If xlApp Is Nothing Then
MsgBox "No Excel running instance", vbCritical + vbInformation
Exit Sub
End If
With xlApp.Sheets("Sheet1") '<--| this assumes that the running instance of excel has an open workbook with a sheet named "Sheet1"
StartDate = .Range("A1").Value
EndDate = .Range("B1").Value
For Each item In oItems
MailDate = DateValue(item.ReceivedTime)
If MailDate >= StartDate And MailDate <= EndDate Then
pos = InStr(item.Subject, "Keyword:") '<--| search for "Keyword:" in current mail subject
If pos > 0 Then '<--| if found...
phrasesArr = Split(Right(item.Subject, Leng(item.Subject) - pos - Len("keyword:")), ",") '<-- fill an array with "phrases" separated by commas after "keyword:"
.Range("C" & .Rows.Count).End(xlUp).Offset(1).Resize(, UBound(phrasesArr) + 1).Value = phrasesArr '<--| write "phrases" in column "C" first non empty cell and its adjacent cells
End If
End If
Next
End With
Set xlApp = Nothing
Set oItems = Nothing
Set oFoldToSearch = Nothing
Set oTaskFolder = Nothing
Set oNS = Nothing
End Sub
Function GetExcel(Optional mustBeCurrent As Variant) As Excel.Application
Dim excelApp As Excel.Application
If IsMissing(mustBeCurrent) Then mustBeCurrent = False '<--| default is get an Excel object "at any cost", if it's not running then create it
On Error Resume Next
Set GetExcel = GetObject(, "Excel.Application") '<--| try getting a running Excel application
On Error GoTo 0
If GetExcel Is Nothing Then If Not mustBeCurrent Then Set GetExcel = CreateObject("Excel.Application") '<--| if no running instance of Excel has been found then open a new one
End Function
I have Excel-2007. I am using File System Object VBA code to list files in a directory. I have also set up reference to Microsoft Scriptlet Library in excel.
I am getting:
Compiler error:User-defined type not defined
on this very first code line
Dim FSO As Scripting.FileSystemObject
Code used by me as follows:
Sub ListFilesinFolder()
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim FileItem As Scripting.File
SourceFolderName = "C:\mydir"
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
Range("A1:C1") = Array("text file", "path", "Date Last Modified")
i = 2
For Each FileItem In SourceFolder.Files
Cells(i, 1) = FileItem.Name
Cells(i, 2) = FileItem
Cells(i, 3) = FileItem.DateLastModified
i = i + 1
Next FileItem
Set FSO = Nothing
End Sub
Can someone point out where am I going wrong?
**UPDATE -03-09-2015**
I have updated my program based on #brettdj program and some research to list all files including sub-folder files. It works for me. I look forward to suggestions to further improve it.
Sub ListFilesinFolder()
Dim objFSO As Object
Dim ws As Worksheet
Dim cl As Range
Dim objFolderName As String
objFolderName = "C:\FY_2015-2016\sunil"
Set objFSO = New Scripting.FileSystemObject
Set ws = ActiveSheet
With Range("A1:C1")
.Value2 = Array("File", "path", "Date Last Modified")
.Font.Bold = True
End With
Set cl = ws.Cells(2, 1)
ListFolders cl, objFSO.GetFolder(objFolderName)
Set objFSO = Nothing
End Sub
Sub ListFolders(rng As Range, Fol As Scripting.Folder)
Dim SubFol As Scripting.Folder
Dim FileItem As Scripting.File
' List Files
For Each FileItem In Fol.Files
rng.Cells(1, 1) = FileItem.Name
rng.Cells(1, 2) = FileItem.ParentFolder.Path
rng.Cells(1, 3) = FileItem.DateLastModified
Set rng = rng.Offset(1, 0)
Next
' Proces subfolders
For Each SubFol In Fol.SubFolders
ListFolders rng, SubFol
Next
With ActiveSheet
.Columns.EntireColumn.AutoFit
End With
End Sub
I am posting another update which is not cell by cell filling.
REVISED UPDATE ON 3-09-2015
Sub GetFileList()
Dim strFolder As String
Dim objFSO As Object
Dim objFolder As Object
Dim myResults As Variant
Dim lCount As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Get the directory from the user
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 0 Then Exit Sub
'user cancelled
strFolder = .SelectedItems(1)
End With
Set objFolder = objFSO.GetFolder(strFolder)
'the variable dimension has to be the second one
ReDim myResults(0 To 5, 0 To 0)
' place make some headers in the array
myResults(0, 0) = "Filename"
myResults(1, 0) = "Size"
myResults(2, 0) = "Created"
myResults(3, 0) = "Modified"
myResults(4, 0) = "Accessed"
myResults(5, 0) = "Full path"
'Send the folder to the recursive function
FillFileList objFolder, myResults, lCount
' Dump these to a worksheet
fcnDumpToWorksheet myResults
'tidy up
Set objFSO = Nothing
End Sub
Private Sub FillFileList(objFolder As Object, ByRef myResults As Variant, ByRef lCount As Long, Optional strFilter As String)
Dim i As Integer
Dim objFile As Object
Dim fsoSubFolder As Object
Dim fsoSubFolders As Object
'load the array with all the files
For Each objFile In objFolder.Files
lCount = lCount + 1
ReDim Preserve myResults(0 To 5, 0 To lCount)
myResults(0, lCount) = objFile.Name
myResults(1, lCount) = objFile.Size
myResults(2, lCount) = objFile.DateCreated
myResults(3, lCount) = objFile.DateLastModified
myResults(4, lCount) = objFile.DateLastAccessed
myResults(5, lCount) = objFile.Path
Next objFile
'recursively call this function with any subfolders
Set fsoSubFolders = objFolder.SubFolders
For Each fsoSubFolder In fsoSubFolders
FillFileList fsoSubFolder, myResults, lCount
Next fsoSubFolder
End Sub
Private Sub fcnDumpToWorksheet(varData As Variant, Optional mySh As Worksheet)
Dim iSheetsInNew As Integer
Dim sh As Worksheet, wb As Workbook
Dim myColumnHeaders() As String
Dim l As Long, NoOfRows As Long
If mySh Is Nothing Then
'make a workbook if we didn't get a worksheet
iSheetsInNew = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set wb = Application.Workbooks.Add
Application.SheetsInNewWorkbook = iSheetsInNew
Set sh = wb.Sheets(1)
Else
Set mySh = sh
End If
'since we switched the array dimensions, have to transpose
With sh
Range(.Cells(1, 1), .Cells(UBound(varData, 2) + 1, UBound(varData, 1) + 1)) = _
Application.WorksheetFunction.Transpose(varData)
.UsedRange.Columns.AutoFit
End With
Set sh = Nothing
Set wb = Nothing
End Sub
Would recommend using an array approach for speed
Sub ListFilesinFolder()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim lngCnt As Long
Dim X
objFolderName = "C:\temp"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(objFolderName)
ReDim X(1 To objFolder.Files.Count, 1 To 3)
For Each objFile In objFolder.Files
lngCnt = lngCnt + 1
X(lngCnt, 1) = objFile.Name
X(lngCnt, 2) = objFile.Path
X(lngCnt, 3) = Format(objFile.DateLastModified, "dd-mmm-yyyy")
Next
[a2].Resize(UBound(X, 1), 3).Value2 = X
With Range("A1:C1")
.Value2 = Array("text file", "path", "Date Last Modified")
.Font.Bold = True
.Columns.EntireColumn.AutoFit
End With
End Sub
You're referencing Microsoft Scriptlet Library; should be Microsoft Scripting Runtime.
Try this:
Sub ListFilesinFolder()
Dim FSO
Dim SourceFolder
Dim FileItem
SourceFolderName = "C:\mydir"
Set FSO = CreateObject("Scripting.FileSystemObject") '<-- New change
Set SourceFolder = FSO.GetFolder(SourceFolderName)
Range("A1:C1") = Array("text file", "path", "Date Last Modified")
i = 2
For Each FileItem In SourceFolder.Files
Cells(i, 1) = FileItem.Name
Cells(i, 2) = FileItem
Cells(i, 3) = FileItem.DateLastModified
i = i + 1
Next FileItem
Set FSO = Nothing
End Sub