Merging two MACRO scripts (WORD) - excel

I have two Macro scripts, both are working perfectly individually! But I want to marge them and have 1 script.
Basically, I want to save all pages in a WORD document (like 100 pages) as PDF and name each file according to the 3rd line of each page.
So first script is the following which converts to PDF:
Sub SaveAsSeparatePDFs()
Dim strDirectory As String, strTemp As String, ipgEnd As Integer
Dim iPDFnum As Integer, i As Integer
strTemp = InputBox("How many pages is included?" & vbNewLine & "(ex: 60)")
ipgEnd = CInt(strTemp)
strDirectory = Environ("USERPROFILE") & "\Desktop"
iPDFnum = 1
For i = 1 To ipgEnd
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
strDirectory & "\User--" & iPDFnum & FirstPara & ".pdf", ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, Range:= _
wdExportFromTo, From:=i, To:=i + 1, Item:=wdExportDocumentContent, _
IncludeDocProps:=False, KeepIRM:=False, CreateBookmarks:= _
wdExportCreateHeadingBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=False, UseISO19005_1:=False
iPDFnum = iPDFnum + 1
i = i + 1
Next i
End
End Sub
And here is the second script which renames each file according to third line of the WORD doc:
Sub SaveAsWordAndRename()
Dim oSection As Section
Dim r As Range
Dim TempDoc As Document
Dim FirstPara As String
Dim strDirectory As String, strTemp As String, ipgEnd As Integer
Dim iPDFnum As Integer, i As Integer
For Each oSection In ActiveDocument.Sections
Set r = oSection.Range
r.End = r.End - 1
Set TempDoc = Documents.Add
With TempDoc
.Range = r
FirstPara = r.Paragraphs(3).Range.Text
FirstPara = Left(FirstPara, Len(FirstPara) - 1)
.SaveAs FileName:=FirstPara & ".doc"
.Close
End With
Set r = Nothing
Set TempDoc = Nothing
Next
End Sub

Related

How to set OLEObject name using a variable?

How do I rename an OLEObject?
The object is embedded and the oname variable works when used in the other lines but the .name command will not work. There is no error.
Public Sub insertFiles()
Dim newObject As Object
Dim oname As String
Dim CheckName As String
CheckName = UserForm1.MultiPage2.SelectedItem.Caption
oname = CheckName & "_" & "Evidence" & "_" & UserForm1.ProjectName.Value & "_" & Format(Date, "ddmmmyyyy")
Worksheets("Emails").Activate
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Set Rng = ActiveCell
Rng.RowHeight = 70
On Error Resume Next
fpath = Application.GetOpenFilename("All Files,*.*", Title:="Select file")
If LCase(fpath) = "false" Then Exit Sub
If UserForm1.ProjectName.Value <> Empty Then
ActiveCell.Value = "."
ActiveSheet.OLEObjects.Add(Filename:=fpath, _
Link:=False, _
DisplayAsIcon:=True, _
IconFileName:="Outlook.msg", _
IconIndex:=1, _
IconLabel:=extractFileName(fpath)).Name = oname
ActiveCell.Offset(0, 1).Value = oname
UserForm1.Attached1.Value = oname
ThisWorkbook.Worksheets("Output").Range("B35").Value = oname
Call UserForm1.Tickbox
UserForm1.LablePIA.Visible = True
UserForm1.Attached1.Visible = True
UserForm1.View.Visible = True
UserForm1.Deleteemail.Visible = True
MsgBox "Attachment uploaded"
Else
MsgBox "Project Name must be input before emails can be uploaded"
End If
End Sub
Public Function extractFileName(filePath)
For i = Len(filePath) To 1 Step -1
If Mid(filePath, i, 1) = "\" Then
extractFileName = Mid(filePath, i + 1, Len(filePath) - i + 1)
Exit Function
End If
Next
End Function
Solution:
The string variable contained too many characters, apparently the max is 35.
OLEObject names cannot exceed 35 characters (presumably unless you use a class module etc!).
Try like this
Dim Obj As OLEObject
set Obj = ActiveSheet.OLEObjects.Add(Filename:=fpath, _
Link:=False, _
DisplayAsIcon:=True, _
IconFileName:="Outlook.msg", _
IconIndex:=1, _
IconLabel:=extractFileName(fpath))
Obj.name = oname

Search some text/word in folder containing bunch of PDF files and get count of PDF contains that text/word - Without opening pdf files

Aim - I want VBA code that should search specific text/word in content inside bunch of pdf files and give me COUNT of PDF contains that word (without opening pdf files)
Currently I have code found on internet giving me count of PDF files that contains specific text in the > Name of pdf files <
But as mentioned I want to modify below code/give me new code that should give me COUNT of pdf files contains that specific word inside the PDF content
Below is the current code I have
Sub PDFCONTENT()
Dim i As Long
Dim x As Integer
Dim Folder As String
Dim ExcelFN As String
Dim NumFiles As Integer
Dim filename As String
Dim FinsS As String
For i = 2 To Range("A" & Rows.count).End(xlDown).Row
NumFiles = 0
Folder = Sheets("Sheet1").Range("A" & i).Value
ExcelFN = Sheets("Sheet1").Range("B" & i).Value
filename = Dir(Folder & "*" & ExcelFN & "*")
Do While filename <> ""
NumFiles = NumFiles + 1
filename = Dir()
Loop
Sheets("Sheet1").Range("C" & i) = NumFiles
Next i
End Sub
I don't see how you will get the content of the PDF files, or any files for that matter, without opening the files. Also, you will need Adobe Acrobat installed to scan PDF files using VBA. I don't know how much it costs, but it's not free. If you want a free option, convert all PDF files into Word files and then do scans on those.
Sub ConvertToWord()
Dim MyObj As Object, MySource As Object, file As Variant
file = Dir("C:\Users\Excel\Desktop\test\" & "*.pdf") 'pdf path
Do While (file <> "")
ChangeFileOpenDirectory "C:\Users\Excel\Desktop\test\"
Documents.Open FileName:=file, ConfirmConversions:=False, ReadOnly:= _
False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _
"", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _
Format:=wdOpenFormatAuto, XMLTransform:=""
ChangeFileOpenDirectory "C:\Users\Excel\Desktop\test\" 'path for saving word
ActiveDocument.SaveAs2 FileName:=Replace(file, ".pdf", ".docx"), FileFormat:=wdFormatXMLDocument _
, LockComments:=False, Password:="", AddToRecentFiles:=True, _
WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False, CompatibilityMode:=15
ActiveDocument.Close
file = Dir
Loop
End Sub
Then, run this code below, in Excel.
Sub OpenAndReadWordDoc()
Rows("2:1000000").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A1").Select
' assumes that the previous procedure has been executed
Dim oWordApp As Word.Application
Dim oWordDoc As Word.Document
Dim blnStart As Boolean
Dim r As Long
Dim sFolder As String
Dim strFilePattern As String
Dim strFileName As String
Dim sFileName As String
Dim ws As Worksheet
Dim c As Long
Dim n As Long
Dim iCount As Long
Dim strSearch As String
'~~> Establish an Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err Then
Set oWordApp = CreateObject("Word.Application")
' We started Word for this macro
blnStart = True
End If
On Error GoTo ErrHandler
Set ws = ActiveSheet
r = 1 ' startrow for the copied text from the Word document
' Last column
n = ws.Range("A1").End(xlToRight).Column
sFolder = "C:\Users\Excel\Desktop\test\"
'~~> This is the extension you want to go in for
strFilePattern = "*.doc*"
'~~> Loop through the folder to get the word files
strFileName = Dir(sFolder & strFilePattern)
Do Until strFileName = ""
sFileName = sFolder & strFileName
'~~> Open the word doc
Set oWordDoc = oWordApp.Documents.Open(sFileName)
' Increase row number
r = r + 1
' Enter file name in column A
ws.Cells(r, 1).Value = sFileName
ActiveCell.Offset(1, 0).Select
ActiveSheet.Hyperlinks.Add Anchor:=Sheets("Sheet1").Range("A" & r), Address:=sFileName, _
SubAddress:="A" & r, TextToDisplay:=sFileName
' Loop through the columns
For c = 2 To n
If oWordDoc.Content.Find.Execute(FindText:=Trim(ws.Cells(1, c).Value), _
MatchWholeWord:=True, MatchCase:=False) Then
strSearch = ws.Cells(1, c).Value
iCount = 0
With ActiveDocument.Content.Find
.Text = strSearch
.Format = False
.Wrap = wdFindStop
Do While .Execute
iCount = iCount + 1
Loop
End With
ws.Cells(r, c).Value = iCount
End If
Next c
oWordDoc.Close SaveChanges:=False
'~~> Find next file
strFileName = Dir
Loop
ExitHandler:
On Error Resume Next
' close the Word application
Set oWordDoc = Nothing
If blnStart Then
' We started Word, so we close it
oWordApp.Quit
End If
Set oWordApp = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
Function GetDirectory(path)
GetDirectory = Left(path, InStrRev(path, "\"))
End Function
Here, the counts are the same because I copied/pasted the same file 4x so I had something to loop over.

Excel InitialFileName Not Working With Period

In the document I have a button to do a save as, this function takes a path and creates the filename based off a cell and the date. This has been working fine until a path came up that has a period in it, it will locate the path correctly but is no longer filling in the filename.
Sub SaveWorkbookAsNewFile()
Dim NewFileType As String
Dim NewFile As String
Dim newfilename As String
Dim cellname As String
Dim monthnum As String
Dim monthtxt As String
Dim daynum As String
Dim yearnum As String
Dim yeartxt As String
Dim SaveArea As String
Dim q As Long
If Worksheets.Count <= 6 Then MsgBox "You must run the report before saving it.", vbInformation, "Save Error": End
SaveArea = Sheet1.Range("K12")
cellname = Sheet1.Range("K20")
'********************************************************************
Dim objFSO As Object, objFolder As Object, objSubFolder As Object
Dim varDirectory As Variant
Dim flag As Boolean
Dim strDirectory As String, goodfolder As String
Dim NumMonth As Integer
NumMonth = 0
q = 0
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(SaveArea)
NumMonth = Month(Date)
For Each objSubFolder In objFolder.subfolders
If InStr(1, UCase(objSubFolder.Name), UCase(MonthName(NumMonth, True)), vbTextCompare) > 1 Then goodfolder = objSubFolder.Name: Exit For
Next objSubFolder
If Not goodfolder = "" Then SaveArea = SaveArea & goodfolder & "\"
'********************************************************************
monthnum = Month(Date)
monthtxt = UCase(MonthName(monthnum, True))
daynum = Day(Date)
yearnum = Year(Date)
yeartxt = Right(yearnum, 2)
newfilename = cellname & "-" & monthtxt & "-" & daynum & "-" & yeartxt
Application.ScreenUpdating = False ' Prevents screen refreshing.
NewFileType = "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm," & _
"All files (*.*), *.*"
NewFile = Application.GetSaveAsFilename( _
InitialFileName:=SaveArea & newfilename, _
fileFilter:=NewFileType)
If NewFile <> "" And NewFile <> "False" Then
ActiveWorkbook.SaveAs FileName:=NewFile, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, _
CreateBackup:=False, _
ConflictResolution:=xlUserResolution
End If
Application.ScreenUpdating = True
End Sub
A working path (SaveArea) is as follows: \\TestServer\Test\Test\Standards\Test\Test 1\
A broken path (SaveArea) is as follows: \\TestServer\Test\Test\Standards\Test\Test. 1\
Both bring up the save as dialog, but the path with the period does not populate a filename. Is there a way to make this work when the path includes a period?
Edit: I've found a similar post here but it doesn't have a solution to fix the problem.
To get this to work, add the file extension to the InitialFileName parameter like below:
NewFile = Application.GetSaveAsFilename( _
InitialFileName:=SaveArea & newfilename & ".xlsm", _
fileFilter:=NewFileType)

Search VBA code across multiple Excel files

I have about 100 macros in a folder, and I'm looking for one in particular that contains a VBA module with function called addGBE - I forget WHICH file it's in though. Is there any software program that allows me to search within the VBA code of files in a specific folder?
Make Windows Search look within MS Office and other Compressed files
Starting with Microsoft Office 2007, the Office Open XML (OOXML) file formats have become the default file format.
File types such as .XLSX, .XLSM and .DOCX use XML architecture and ZIP compression to store things like text and formulas into cells that are organized into rows and columns. For example, simply changing a .XLSM' file's extension to.ZIP` allows you to open it as a compressed file and view the files that make up the Excel workbook.
By tweaking a few settings we can ensure that Windows Search always searches within OOXML and other compressed file formats.
My example uses Windows 7, but Windows 10 has equivalent settings.
Specify which filetypes should be indexed
Hit +E an browse to the folder where you keep your Office or Compressed files are stored.
Hit Alt+T to open the Tools menu and click Folder Options
Specify which filetypes to always search within
Go to the Search tab
Make sure Always search filenames and contents is selected
Make sure Include compressed is checked
Apply change to other folders:
At this point you can either:
repeat the above steps on any other folders on which you want to change these options, or,
go to the View tab and click Apply to Folders to make all folders look/act like the current one.
Caution! This will copy all of the current folder settings to all other folders, including displayed columns, sort order, view, etc., so be aware that you may lose unique setups for individual folders.
Personally, I'll take the time to setup one folder exactly how I like it, and implement everywhere with a single click.
Open Indexing Options:
Hit the Windows Key
Type index click Indexing Options or hit Enter
click Modify to open a filetree to specify which folders should be included in the Index.
I like to include all folders, but this negatively impacts overall performance if you have a ton of data on the drive(s).
In the Indexing Options dialog:
click the Advanced tab
in the Advanced Options dialog, go to the File Types tab.
This is where you specify which filetypes the indexer should always search within.
Go through the list looking for each Open Office XML filetype (like .XLSM and DOCX)
Select Index Properties and File Contents.
Repeat for any compressed filetypes you want to include (such as .ZIP and .RAR)
When finished click OK
]10
Force re-index:
When you're finished customizing the Indexing options:
On the Indexing Options dialog, click Rebuild to build a new index file.
Note that re-indexing can take a really long time to complete, especially if you're actively using the device and/or you have a ton of data stored locally.
You can optionally close the Indexing dialog with the × and the process will continue in the background.
I found some old code (2006) that I've updated. It will open a box to enter search string then open a dir dialog box to select folder. It will then search through all modules and display a msgbox displaying file name and sheet/module name where string was found. I did not make this, just updated. Orig found here. See here for Microsoft documentation on checking for 64bit and declaring data types properly.
Option Explicit
#If VBA7 And Win64 Then ' VBA7
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Type BROWSEINFO
hOwner As LongPtr
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As LongPtr
lParam As LongPtr
iImage As Long
End Type
#Else ' Downlevel when using previous version of VBA7
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
#End If
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim R As Long
Dim x As Long
Dim pos As Integer
'Root folder (&H0 for Desktop, &H11 for My Computer)
bInfo.pidlRoot = &H0
'Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
'Type of directory to return
bInfo.ulFlags = &H1
'Display the dialog
x = SHBrowseForFolder(bInfo)
'Parse the result
Path = Space$(512)
R = SHGetPathFromIDList(ByVal x, ByVal Path)
If R Then
pos = InStr(Path, Chr$(0))
GetDirectory = Left(Path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Function RecursiveFindFiles(strPath As String, _
strSearch As String, _
Optional bSubFolders As Boolean = True, _
Optional bSheet As Boolean = False, _
Optional lFileCount As Long = 0, _
Optional lDirCount As Long = 0) As Variant
'adapted from the MS example:
'http://support.microsoft.com/default.aspx?scid=kb;en-us;185476
'---------------------------------------------------------------
'will list all the files in the supplied folder and it's
'subfolders that fit the strSearch criteria
'lFileCount and lDirCount will always have to start as 0
'---------------------------------------------------------------
Dim strFileName As String 'Walking strFileName variable.
Dim strDirName As String 'SubDirectory Name.
Dim arrDirNames() As String 'Buffer for directory name entries.
Dim nDir As Long 'Number of directories in this strPath.
Dim i As Long 'For-loop counter.
Dim n As Long
Dim arrFiles
Static strStartDirName As String
Static strpathOld As String
On Error GoTo sysFileERR
If lFileCount = 0 Then
Static collFiles As Collection
Set collFiles = New Collection
Application.Cursor = xlWait
End If
If Right$(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
If lFileCount = 0 And lDirCount = 0 Then
strStartDirName = strPath
End If
'search for subdirectories
'-------------------------
nDir = 0
ReDim arrDirNames(nDir)
strDirName = Dir(strPath, _
vbDirectory Or _
vbHidden Or _
vbArchive Or _
vbReadOnly Or _
vbSystem) 'Even if hidden, and so on.
Do While Len(strDirName) > 0
'ignore the current and encompassing directories
'-----------------------------------------------
If (strDirName <> ".") And (strDirName <> "..") Then
'check for directory with bitwise comparison
'-------------------------------------------
If GetAttr(strPath & strDirName) And vbDirectory Then
arrDirNames(nDir) = strDirName
lDirCount = lDirCount + 1
nDir = nDir + 1
DoEvents
ReDim Preserve arrDirNames(nDir)
End If 'directories.
sysFileERRCont1:
End If
strDirName = Dir() 'Get next subdirectory
DoEvents
Loop
'Search through this directory
'-----------------------------
strFileName = Dir(strPath & strSearch, _
vbNormal Or _
vbHidden Or _
vbSystem Or _
vbReadOnly Or _
vbArchive)
While Len(strFileName) <> 0
'dump file in sheet
'------------------
If bSheet Then
If lFileCount < 65536 Then
Cells(lFileCount + 1, 1) = strPath & strFileName
End If
End If
lFileCount = lFileCount + 1
collFiles.Add strPath & strFileName
If strPath <> strpathOld Then
Application.StatusBar = " " & lFileCount & _
" " & strSearch & " files found. " & _
"Now searching " & strPath
End If
strpathOld = strPath
strFileName = Dir() 'Get next file
DoEvents
Wend
If bSubFolders Then
'If there are sub-directories..
'------------------------------
If nDir > 0 Then
'Recursively walk into them
'--------------------------
For i = 0 To nDir - 1
RecursiveFindFiles strPath & arrDirNames(i) & "\", _
strSearch, _
bSubFolders, _
bSheet, _
lFileCount, _
lDirCount
DoEvents
Next
End If 'If nDir > 0
'only bare main folder left, so get out
'--------------------------------------
If strPath & arrDirNames(i) = strStartDirName Then
ReDim arrFiles(1 To lFileCount) As String
For n = 1 To lFileCount
arrFiles(n) = collFiles(n)
Next
RecursiveFindFiles = arrFiles
Application.Cursor = xlDefault
Application.StatusBar = False
End If
Else 'If bSubFolders
ReDim arrFiles(1 To lFileCount) As String
For n = 1 To lFileCount
arrFiles(n) = collFiles(n)
Next
RecursiveFindFiles = arrFiles
Application.Cursor = xlDefault
Application.StatusBar = False
End If 'If bSubFolders
Exit Function
sysFileERR:
Resume sysFileERRCont1
End Function
Function FileFromPath(ByVal strFullPath As String, _
Optional bExtensionOff As Boolean = False) _
As String
Dim FPL As Long 'len of full path
Dim PLS As Long 'position of last slash
Dim pd As Long 'position of dot before exension
Dim strFile As String
On Error GoTo ERROROUT
FPL = Len(strFullPath)
PLS = InStrRev(strFullPath, "\", , vbBinaryCompare)
strFile = Right$(strFullPath, FPL - PLS)
If bExtensionOff = False Then
FileFromPath = strFile
Else
pd = InStr(1, strFile, ".", vbBinaryCompare)
FileFromPath = Left$(strFile, pd - 1)
End If
Exit Function
ERROROUT:
On Error GoTo 0
FileFromPath = ""
End Function
Sub SearchWBsForCode()
Dim strTextToFind As String
Dim strFolder As String
Dim arr
Dim i As Long
Dim strWB As String
Dim VBProj As VBProject
Dim VBComp As VBComponent
Dim lStartLine As Long
Dim lEndLine As Long
Dim lFound As Long
Dim lType As Long
Dim lSkipped As Long
Dim oWB As Workbook
Dim bOpen As Boolean
Dim bNewBook As Boolean
strTextToFind = InputBox("Type the text to find", _
"finding text in VBE")
If Len(strTextToFind) = 0 Or StrPtr(strTextToFind) = 0 Then
Exit Sub
End If
strFolder = GetDirectory()
If Len(strFolder) = 0 Then
Exit Sub
End If
lType = Application.InputBox("Type file type to search" & _
vbCrLf & vbCrLf & _
"1. Only .xls files" & vbCrLf & _
"2. Only .xla files" & vbCrLf & _
"3. Either file type", _
"finding text in VBE", 1, Type:=1)
Select Case lType
Case 1
arr = RecursiveFindFiles(strFolder, "*.xls", True, True)
Case 2
arr = RecursiveFindFiles(strFolder, "*.xla", True, True)
Case 3
arr = RecursiveFindFiles(strFolder, "*.xl*", True, True)
Case Else
Exit Sub
End Select
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
For i = 1 To UBound(arr)
Application.StatusBar = i & "/" & UBound(arr) & _
" - Searching " & arr(i)
strWB = FileFromPath(arr(i))
On Error Resume Next
Set oWB = Workbooks(strWB)
If oWB Is Nothing Then
bOpen = False
Workbooks.Open arr(i)
Else
'for preventing closing WB's that are open already
bOpen = True
Set oWB = Nothing
End If
bNewBook = True
For Each VBComp In Workbooks(strWB).VBProject.VBComponents
If Err.Number = 50289 Then 'for protected WB's
lSkipped = lSkipped + 1
Err.Clear
GoTo PAST
End If
lEndLine = VBComp.CodeModule.CountOfLines
If VBComp.CodeModule.Find(strTextToFind, _
lStartLine, _
1, _
lEndLine, _
-1, _
False, _
False) = True Then
If bNewBook = True Then
lFound = lFound + 1
bNewBook = False
End If
Application.ScreenUpdating = True
If MsgBox("Workbook: " & arr(i) & vbCrLf & _
"VBComponent: " & VBComp.Name & vbCrLf & _
"Line number: " & lStartLine & _
vbCrLf & vbCrLf & _
"WB's found so far: " & lFound & vbCrLf & _
"Protected WB's skipped: " & lSkipped & _
vbCrLf & vbCrLf & _
"Stop searching?", _
vbYesNo + vbDefaultButton1 + vbQuestion, _
i & "/" & UBound(arr) & _
" - found " & strTextToFind) = vbYes Then
With Application
.StatusBar = False
.EnableEvents = True
.DisplayAlerts = True
End With
With VBComp.CodeModule.CodePane
.SetSelection lStartLine, 1, lStartLine, 1
.Show
End With
Exit Sub
End If
Application.ScreenUpdating = False
End If
Next
PAST:
If bOpen = False Then
Workbooks(strWB).Close savechanges:=False
End If
On Error GoTo 0
Next
On Error Resume Next
If bOpen = False Then
Workbooks(strWB).Close savechanges:=False
End If
With Application
.ScreenUpdating = True
.StatusBar = False
.EnableEvents = True
.DisplayAlerts = True
End With
MsgBox lFound & " WB's found with " & strTextToFind & " in VBE" & _
vbCrLf & vbCrLf & _
"protected WB's skipped: " & lSkipped, , _
"finding text in VBE"
End Sub

Output an array of data collected from a file to a specific sheet in Master workbook

The following code opens selected files, one at a time; if a file contains specific text string in B11 (there are four variation: LS2A, LS1PRA, LS1A and LSM12), specified data from Sheet(1) of each file is copied into an array. The search is performed by function “SearchFor” that is called in the main routine.
The array ArrCopy is filled with data from each file and should output into one of the four sheets in Master Workbook(SABI, SABII,LSM or LPRI&II). The output sheet is determined by the text string in B11 of each file.
I can’t get data to output to Master workbook for some reason. I've tried Debug.Print each array item after it's filled and I can see that the array is filled with correct data but I can't get the values to tranfer to the master workbook. The code runs but nothing is outputed on the worksheet.
Please suggest how to make this work. Thanks
Option Explicit
Function SearchFor(output As Worksheet)
Dim rowsCount As Long
Dim NCBead1 As Long, NCBead2 As Long, PCBead1 As Long, PCBead2 As Long
Dim IniString As String, IniVar As String
Dim rngCell As Range, rngCell2 As Range
Dim ArrCopy(1 To 9) As Variant
Dim LastRow As Long
Dim aCell As Range
LastRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
'extract initial after last underscore
IniString = ActiveWorkbook.Sheets(1).Range("B6").Value
IniVar = Right(IniString, Len(IniString) - InStrRev(IniString, "_", , 1))
Debug.Print IniVar
'Debug.Print "LastRow = " & LastRow
Set aCell = ActiveSheet.Range("B1:B" & LastRow).Find(What:="Trimmed Mean", LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'Debug.Print "Trimmed Mean can be found in Row # " & aCell.Row
'wb.Sheets(1).Select
For Each rngCell In ActiveSheet.Range("B" & aCell.Row & ":B" & LastRow)
If InStr(rngCell, "NC") > 0 Then
Debug.Print rngCell.Row
NCBead1 = rngCell.Offset(0, 1).Value
NCBead2 = rngCell.Offset(0, 2).Value
'End If
Exit For
End If
Next rngCell
For Each rngCell2 In ActiveSheet.Range("B" & aCell.Row & ":B" & LastRow)
If InStr(rngCell2, "PC") > 0 Then
Debug.Print rngCell2.Row
PCBead1 = rngCell2.Offset(0, 1).Value
PCBead2 = rngCell2.Offset(0, 2).Value
'End If
Exit For
End If
Next rngCell2
'Next searched
Debug.Print NCBead2
ArrCopy(1) = ActiveSheet.Range("B3").Value
ArrCopy(2) = IniVar
ArrCopy(3) = NCBead1
ArrCopy(4) = NCBead2
ArrCopy(5) = PCBead1
ArrCopy(6) = PCBead2
ArrCopy(7) = ActiveSheet.Range("B6").Value
ArrCopy(8) = NCBead1
ArrCopy(9) = NCBead1
' one row spanning several columns
Debug.Print "ArrCopy" & ArrCopy(1)
Debug.Print "ArrCopy" & ArrCopy(2)
Debug.Print "ArrCopy" & ArrCopy(3)
Dim Destination As Range
Set Destination = output.Range("A" & output.Range("A" & Rows.Count).End(xlUp).Row + 1)
Set Destination = Destination.Resize(1, UBound(ArrCopy))
Destination.Value = ArrCopy
End Function
Sub openselectedfiles()
Dim SaveDriveDir As String, MyPath As String, FnameInLoop As String
Dim mybook As Workbook, thisWb As Workbook
Dim N As Long, LstUnderSc As Long, ExtPer As Long, Varin As Long
Dim Fname As Variant, ArrCopy(1 To 9) As Variant
Dim output As Worksheet
Dim inLS2A As Boolean, inLS1PRA As Boolean, inLS1A As Boolean, inLSM12 As Boolean
Set thisWb = ThisWorkbook
' Save the current directory.
SaveDriveDir = CurDir
' Set the path to the folder that you want to open.
MyPath = Application.DefaultFilePath
' Change drive/directory to MyPath.
ChDrive MyPath
ChDir MyPath
' Open GetOpenFilename with the file filters.
Fname = Application.GetOpenFilename( _
FileFilter:="CSV Files (*.csv),*.csv", _
Title:="Select a file or files", _
MultiSelect:=True)
' Perform some action with the files you selected.
If IsArray(Fname) Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For N = LBound(Fname) To UBound(Fname)
' Get only the file name and test to see if it is open.
FnameInLoop = Right(Fname(N), Len(Fname(N)) - InStrRev(Fname(N), Application.PathSeparator, , 1))
If bIsBookOpen(FnameInLoop) = False Then
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(Fname(N))
On Error GoTo 0
If Not mybook Is Nothing Then
mybook.Sheets(1).Select
With ActiveSheet.Range("B11")
inLS2A = InStr(1, .Value, "LS2A", 1) > 0
inLS1PRA = InStr(1, .Value, "LS1PRA", 1) > 0
inLS1A = InStr(1, .Value, "LS1A", 1) > 0
inLSM12 = InStr(1, .Value, "LSM12", 1) > 0
End With
If inLS2A Then
Set output = thisWb.Sheets("SABII")
SearchFor output
ElseIf inLS1PRA Then
Set output = thisWb.Sheets("LPRI&II")
SearchFor output
ElseIf inLS1A Then
Set output = thisWb.Sheets("sabI")
SearchFor output
ElseIf inLSM12 Then
Set output = thisWb.Sheets("LSM")
SearchFor output
End If
'End If
mybook.Close SaveChanges:=False
Set mybook = Nothing
End If
Else
MsgBox "We skipped this file : " & Fname(N) & " because it is already open."
End If
Next N
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
' Change drive/directory back to SaveDriveDir.
ChDrive SaveDriveDir
ChDir SaveDriveDir
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Contributed by Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function

Resources