I am running the following code. The code is for finding some particular values in all the Excel sheets in a folder.
It gives me the error
"Sorry, we couldn't find the file. Is it possible it was moved, renamed or deleted?"
when it executes
Set wbSlave = Workbooks.Open(filename:=myfilname)
Please help.
Sub find_cells()
Dim i, j As Integer
Dim cell_content As String
Dim total_values As Long
Dim cell_location As Range
Dim cell_address As String
Dim sht As Worksheet
Dim myfilname As String
Dim fldrpath As String
Dim wbMaster As Workbook
Dim wbSlave As Workbook
Dim currentfilename As String
Set wbMaster = ThisWorkbook
j = 3
total_values = Application.WorksheetFunction.CountA(wbMaster.Sheets("Engine").Range("A:A"))
fldrpath = "C:\test\"
myfilname = Dir(fldrpath & "*.xls*")
Application.ScreenUpdating = False
Do While myfilname <> ""
'myfilname = Dir()
Set wbSlave = Workbooks.Open(filename:=myfilname)
For Each sht In wbSlave.Sheets
For i = 2 To total_values
cell_content = wbMaster.Sheets("Engine").Range("A" & i).Value
With sht.UsedRange
Set cell_location = .Find(cell_content, LookIn:=xlValues, MatchCase:=False, SearchFormat:=False)
If Not cell_location Is Nothing Then
cell_address = cell_location.Address
Do
wbMaster.Sheets("Sheet1").Columns(j).Value = cell_location.EntireColumn.Value
j = j + 1
Set cell_location = .FindNext(cell_location)
Loop While Not cell_location Is Nothing And cell_location.Address <> cell_address
End If
End With
Set cell_location = Nothing
If i = total_values Then Exit For
Next i
Next
myfilname = Dir()
Loop
End Sub
The Dir function returns only the matching filename - no path. Then if you try to open it and you are currently not in a correct folder, you get this error.
Set a watch to the variable myfilname or just add Debug.Print myfilname and you see it right away.
https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/dir-function
Related
So I came around the net to find answers for this but found none, what I want my code to do is open a worksheet from a folder get the photo from that worksheet and finally paste to a comment inside a cell in my current workbook. here's my code
Dim folder As String
Private Sub Workbook_Open()
folder = ThisWorkbook.path
End Sub
Sub populatePDA()
'Application.ScreenUpdating = False
Dim wb As Workbook
Dim ws As Variant
Dim path As String
Dim fileName As String
Dim p As Picture
Dim img As Variant
Dim cb As Comment
Set ws = ThisWorkbook.Sheets("PDA")
path = folder & "\PDA\"
fileCount = 0
fileName = Dir(path & "*.xlsm")
Do While fileName <> ""
Set wb = Workbooks.Open(path & fileName) 'Open Workbook
ws.Range("A3:F3").Insert (xlShiftDown)
ws.Range("A3") = wb.Sheets(1).Range("B16").Value 'Item Name
ws.Range("B3") = wb.Sheets(1).Range("B17").Value 'S/N
ws.Range("C3") = wb.Sheets(1).Range("G7").Value 'Description
ws.Range("D3") = wb.Sheets(1).Range("H12").Value 'Calibration
ws.Range("E3") = wb.Sheets(1).Range("H13").Value 'Expiration
For Each p In wb.Sheets(1).Pictures
p.CopyPicture
Set img = ws.Paste
Set cb = ws.Range("F3").AddComment
cb.Text Text:=""
cb.Shape.Fill.UserPicture (img)
Next p
wb.Close
fileName = Dir
Loop
'Application.ScreenUpdating = True
End Sub
You do not say anything and I finished something...
I modified a little your code making it to add a new insertion in the working sheet, for a new open file, and process them as (I understood) you need. Please, test the next code:
Sub populatePDA()
Dim fileName As String, path As String
Dim ws As Worksheet, wb As Workbook, p As Shape, fileCount As Long
Dim cb As Comment, i As Long, arrCol As Variant, k As Long
arrCol = Split("A,B,C,D,E", ",")
Set ws = ThisWorkbook.Sheets("PDA")
path = ThisWorkbook.path & "\PDA\"
fileCount = 0
fileName = Dir(path & "*.xlsm")
k = 2
Application.ScreenUpdating = False
Do While fileName <> ""
Set wb = Workbooks.Open(path & fileName) 'Open Workbook
k = k + 1
ws.Range("A" & k & ":E" & k).Insert (xlShiftDown)
ws.Range("A" & k) = wb.Sheets(1).Range("B16").Value 'Item Name
ws.Range("B" & k) = wb.Sheets(1).Range("B17").Value 'S/N
ws.Range("C" & k) = wb.Sheets(1).Range("G7").Value 'Description
ws.Range("D" & k) = wb.Sheets(1).Range("H12").Value 'Calibration
ws.Range("E" & k) = wb.Sheets(1).Range("H13").Value 'Expiration
i = 2
For Each p In wb.Sheets(1).Shapes
If p.Type = msoPicture Then
i = i + 1
ws.Activate
If Not ws.Range(arrCol(i - 3) & k).Comment Is Nothing Then _
ws.Range(arrCol(i - 3) & k).Comment.Delete
Set cb = ws.Range(arrCol(i - 3) & k).AddComment
cb.text text:=""
With cb.Shape
.width = p.width: .height = p.height
End With
cb.Shape.Fill.UserPicture (SelImPathCh(p, wb))
End If
Next p
ws.Activate
wb.Close False
fileName = Dir
Loop
ws.UsedRange.EntireColumn.AutoFit
Application.ScreenUpdating = False
End Sub
The function able to make the picture insertion is the next (it is called by the main above code):
Private Function SelImPathCh(img As Shape, Optional wb As Workbook) As String
Dim ch As ChartObject, sh As Worksheet, sFile As String
If Not wb Is Nothing Then Set sh = wb.Sheets(1)
sFile = ThisWorkbook.path & "\Pict1.jpg"
Set ch = sh.ChartObjects.Add(left:=1, _
top:=1, width:=img.width, _
height:=img.height)
If Not wb Is Nothing Then wb.Activate: sh.Activate
img.Copy: ch.Activate: ActiveChart.Paste
ch.Chart.Export sFile
ch.Delete
SelImPathCh = sFile
End Function
The wb variable is Optional only for my testing need. I used a sheet of the existing working workbook and I skipped it when called the function...
UserPicture works with file path. Try below method, it should work.
Set cb = Worksheets(2).Range("F3").AddComment
cb.Text Text:=""
cb.Shape.Fill.UserPicture ("FILE_PATH")
And if you want to copy picture from worksheet only, then you can export the pictures in tmp folder using the following code and then give the same path in UserPicture.
Sub SaveImages()
Dim shpName As Variant
Dim shp As Shape
Dim ppt As Object, ps As Variant, slide As Variant
Set ppt = CreateObject("PowerPoint.application")
Set ps = ppt.presentations.Add
Set slide = ps.slides.Add(1, 1)
For Each shp In ActiveSheet.Shapes
shpName = "D:\\tmp.jpg"
shp.Copy
With slide
.Shapes.Paste
.Shapes(.Shapes.Count).Export shpName, 2
.Shapes(.Shapes.Count).Delete
End With
Next shp
With ps
.Saved = True
.Close
End With
ppt.Quit
Set ppt = Nothing
End Sub
so my code currently goes through a folder and extracts Ranges of data from every file in the folder into a format set by me, it also extracts the filename.
Now i need to use fso to search for certain string inside the file not the filename, lets say "Smart", and in the file "Smart" appears quite a few times, but i only want to extract it once.
Thank you so much to anyone who is able to provide me the small part of the code or some advices to help me continue on!
Option Explicit
Sub ScanFiles()
Application.ScreenUpdating = False
Dim wks As Worksheet
Set wks = Worksheets.Add
' New worksheet for question 2
Dim wksFSO As Worksheet
' Add headers data
With wks
.Range("A1:E1") = Array("Test", "Temp", "Start", "Type", "FileName", "Test", "EndDate", "Smart", "Er")
End With
' Set your copy ranges
Dim CopyRange(1 To 4) As String
CopyRange(1) = "A18"
CopyRange(2) = "A19"
CopyRange(3) = "A14"
CopyRange(4) = "A19"
' Early Binding - Add "Microsoft Scripting Runtime" Reference
Dim FSO As New Scripting.FileSystemObject
' Set FolderPath
Dim FolderPath As String
FolderPath = "c:\Users\Desktop\Tryout\"
' Set Folder FSO
Dim Folder As Scripting.Folder
Set Folder = FSO.GetFolder(FolderPath)
' Loop thru each file -> Assuming only 6 files
Dim File As Scripting.File
For Each File In Folder.Files
' If loop looking for specific files and copy to new FSOWorksheet
If File.Name Like "ReportFile" Then
wksFSO.Cells(1, 1) = File.Name
End If
Dim wkbData As Workbook
Set wkbData = Workbooks.Open(File.Path)
Dim wksData As Worksheet
ActiveSheet.Name = "Sheet1"
Set wksData = wkbData.Worksheets("Sheet1") ' -> Assume this file has only 1 worksheet
Dim BlankRow As Long
BlankRow = wks.Range("A" & wks.Rows.Count).End(xlUp).Row + 1
Dim i As Long
For i = 1 To 4
wks.Cells(BlankRow, i).Value = wksData.Range(CopyRange(i)).Value
Next i
' Write filename in col E
wks.Cells(BlankRow, 5).Value = File.Name
wkbData.Close False
Next File
Range("A:I").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
This could help you, what it does is it search through the path's folders and each excel file that is inside it for the word that you are going to put in the input box.
Sub SearchFolders()
Dim fso As Object
Dim fld As Object
Dim strSearch As String
Dim strPath As String
Dim strFile As String
Dim wOut As Worksheet
Dim wbk As Workbook
Dim wks As Worksheet
Dim lRow As Long
Dim rFound As Range
Dim strFirstAddress As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
'Change as desired
strPath = "c:\MyFolder"
'You can enter your smart word here
strSearch = inputbox("Please enter a word to be searched.","Search for a word")
Set wOut = Worksheets.Add
lRow = 1
With wOut
.Cells(lRow, 1) = "Workbook"
.Cells(lRow, 2) = "Worksheet"
.Cells(lRow, 3) = "Cell"
.Cells(lRow, 4) = "Text in Cell"
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strPath)
strFile = Dir(strPath & "\*.xls*")
Do While strFile <> ""
Set wbk = Workbooks.Open _
(Filename:=strPath & "\" & strFile, _
UpdateLinks:=0, _
ReadOnly:=True, _
AddToMRU:=False)
For Each wks In wbk.Worksheets
Set rFound = wks.UsedRange.Find(strSearch)
If Not rFound Is Nothing Then
strFirstAddress = rFound.Address
End If
Do
If rFound Is Nothing Then
Exit Do
Else
lRow = lRow + 1
.Cells(lRow, 1) = wbk.Name
.Cells(lRow, 2) = wks.Name
.Cells(lRow, 3) = rFound.Address
.Cells(lRow, 4) = rFound.Value
End If
Set rFound = wks.Cells.FindNext(After:=rFound)
Loop While strFirstAddress <> rFound.Address
Next
wbk.Close (False)
strFile = Dir
Loop
.Columns("A:D").EntireColumn.AutoFit
End With
MsgBox "Done"
ExitHandler:
Set wOut = Nothing
Set wks = Nothing
Set wbk = Nothing
Set fld = Nothing
Set fso = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
How do I adapt this to work with another worksheet rather than the worksheet I have visible.
If (IsEmpty(Cells(RowNum, ColumnNum).Value)) Then
GoTo nextloop:
End If
I have moved parenthesis, tried including workbook name but I think I'm just not getting the syntax. I'm not very good with excel.
What I'm trying to achieve. Take all contents of a column, push the data into a bat file. Script will be launched from a button on another worksheet.
UPDATED Full Code: (Tried Ryan's answer, was getting error. Fixed it but then the script did nothing.)
Sub Send2Bat()
Dim ColumnNum: ColumnNum = 26 ' Column Z - I have the I J and K Columns concatenated there.
Dim RowNum: RowNum = 0
Dim objFSO, objFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.CreateTextFile("C:\Test\Convert.bat") 'Output Path
aFile = "C:\Test\Convert.bat"
Dim OutputString: OutputString = ""
Dim LastRow: LastRow = Application.ActiveSheet.Cells(Application.ActiveSheet.Rows.Count, ColumnNum).End(xlUp).Row
Do
nextloop:
RowNum = RowNum + 1
If (IsEmpty(Cells(RowNum, ColumnNum).Value)) Then
GoTo nextloop:
End If
OutputString = OutputString & Replace(Cells(RowNum, ColumnNum).Value, Chr(10), vbNewLine) & vbNewLine
Loop Until RowNum = LastRow
objFile.Write (OutputString)
Set objFile = Nothing
Set objFSO = Nothing
End Sub
I made an excel workbook and put some data in column z for Sheet 1 and Sheet 2.
And I tweaked your code to read as follows:
Sub Send2Bat()
Dim ColumnNum: ColumnNum = 26 ' Column Z - I have the I J and K Columns concatenated there.
Dim RowNum: RowNum = 0
Dim objFSO, objFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.CreateTextFile("C:\Test\Convert.bat") 'Output Path
aFile = "C:\Test\Convert.bat"
Dim OutputString: OutputString = ""
Dim targetSheet As Worksheet
Set targetSheet = Application.Worksheets("Sheet1")
Dim LastRow: LastRow = targetSheet.Cells(targetSheet.Rows.Count, ColumnNum).End(xlUp).Row
Do
RowNum = RowNum + 1
If Not (IsEmpty(targetSheet.Cells(RowNum, ColumnNum).Value)) Then
OutputString = OutputString & Replace(targetSheet.Cells(RowNum, ColumnNum).Value, Chr(10), vbNewLine) & vbNewLine
End If
Loop Until RowNum = LastRow
objFile.Write (OutputString)
Set objFile = Nothing
Set objFSO = Nothing
End Sub
And it produced the following file:
So then I updated the targetSheet name to "Sheet2"
Set targetSheet = Application.Worksheets("Sheet2")
and executed again. The file updated to this:
So, the code is good at least in its basic form. Do you have anything else updating the sheets or moving things around while this is happening?
I have about 100 Word documents and from each I want to copy data and paste it all in one Excel workbook.
I came up with this code which opens one Word document, copies data, pastes it to Excel and closes the Word document:
Sub WordDataToExcel()
Dim myObj
Dim myWB
Dim mySh
Dim txt As String, Lgth As Long, Strt As Long
Dim i As Long
Dim oRng As Range
Dim Tgt As String
Dim TgtFile As String
Dim arr()
Dim ArrSize As Long
Dim ArrIncrement As Long
ArrIncrement = 1000
ArrSize = ArrIncrement
ReDim arr(ArrSize)
Dim wrdDoc As Object
Documents.Open ("D:\ekr5_i.doc")
TgtFile = "result.xlsx"
Tgt = "D:\" & TgtFile
'finds the text string of Lgth lenght
txt = "thetext"
Lgth = 85
Strt = Len(txt)
'Return data to array
With Selection
.HomeKey unit:=wdStory
With .Find
.ClearFormatting
.Forward = True
.Text = txt
.Execute
While .Found
i = i + 1
Set oRng = ActiveDocument.Range _
(Start:=Selection.Range.Start + Strt, _
End:=Selection.Range.End + Lgth)
arr(i) = oRng.Text
oRng.Start = oRng.End
.Execute
If i = ArrSize - 20 Then
ArrSize = ArrSize + ArrIncrement
ReDim Preserve arr(ArrSize)
End If
Wend
End With
End With
ReDim Preserve arr(i)
'Set target and write data
Set myObj = CreateObject("Excel.Application")
Set myWB = myObj.Workbooks.Open(Tgt)
Set mySh = myWB.Sheets(1)
With mySh
.Range(.Cells(1, 1), .Cells(i, 1)) = myObj.Transpose(arr)
End With
'Tidy up
myWB.Close True
myObj.Quit
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
Set mySh = Nothing
Set myWB = Nothing
Set myObj = Nothing
End Sub
I need to loop through all the documents in the folder.
I have implemented the same with Excel workbooks, but I don't know how for Word documents.
Here is the code for Excel workbooks:
Sub combine_into_one()
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim strPath$, Pivot$, sUserName$, sFolderName$, sSourceName$, x&
Dim oFldialog As FileDialog
Dim oFolder
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set oFldialog = Application.FileDialog(msoFileDialogFolderPicker)
With oFldialog
If .Show = -1 Then
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
sFolderName = .SelectedItems(1)
End If
End With
Set oFolder = FSO.GetFolder(sFolderName)
Workbooks.Add: Pivot = ActiveWorkbook.Name 'Destination workbook
For Each oFile In oFolder.Files
Workbooks(Pivot).Activate
x = Workbooks(Pivot).Sheets(1).Cells.SpecialCells(xlCellTypeLastCell).Row + 1
Workbooks.Open Filename:=oFile: sSourceName = ActiveWorkbook.Name
Workbooks(sSourceName).Activate
Workbooks(sSourceName).Sheets(1).[A80:Q94].copy
Workbooks(Pivot).Activate
Workbooks(Pivot).Sheets(1).Cells(x + 1, 1).PasteSpecial xlPasteAll
Workbooks(sSourceName).Close False
Next
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
There are so, so, so many things you can do between Excel & Word. I'm not sure I totally understand your question. The script below may help you; it has definitely served me well over time. If you need something different, please describe your issue more, to better clarify the issue you are facing.
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
'~~> 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\Coding\Microsoft Excel\PWC\Resumes\"
'~~> 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
' If text found, enter Yes in column number c
ws.Cells(r, c).Value = "Yes"
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
In this scenario, whatever you put in the headers of B1:K1 (or more to the right) is searched for, each word document in a folder is opened, scanned, and if the string in B1:K1 is found, an 'x' is placed in the same x-y coordinate.
Again, if this doesn't help, please describe your issue better, and I'll post back with alternative solutions. Thanks!!
how can I apply delimiter "^" as columns from imported multiple txt files. Pls Help. ..
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim oFileDialog As FileDialog
Dim LoopFolderPath As String
Dim oFileSystem As FileSystemObject
Dim oLoopFolder As Folder
Dim oFilePath As File
Dim oFile As TextStream
Dim RowN As Long
Dim ColN As Long
Dim iAnswer As Integer
On Error GoTo ERROR_HANDLER
Set oFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
RowN = 1
ColN = 1
With oFileDialog
If .Show Then
ActiveSheet.Columns(ColN).Cells.Clear
LoopFolderPath = .SelectedItems(1) & "\"
Set oFileSystem = CreateObject("Scripting.FileSystemObject")
Set oLoopFolder = oFileSystem.GetFolder(LoopFolderPath)
For Each oFilePath In oLoopFolder.Files
Set oFile = oFileSystem.OpenTextFile(oFilePath)
With oFile
Do Until .AtEndOfStream
ActiveSheet.Cells(RowN, ColN).Value = .ReadLine
LoopFolderPath = Space(1)
RowN = RowN + 1
Loop
.Close
End With
Next oFilePath
End If
iAnswer = MsgBox("Your Textfiles have been Inputted.", vbInformation)
End With
EXIT_SUB:
Set oFilePath = Nothing
Set oLoopFolder = Nothing
Set oFileSystem = Nothing
Set oFileDialog = Nothing
Application.ScreenUpdating = True
Exit Sub
ERROR_HANDLER:
' Some code for error handling
Err.Clear
GoTo EXIT_SUB
End Sub
ActiveSheet.RangE("X:X").TextToColumns Destination:=Range("X#"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, Other:=True, OtherChar:="^"
Of course you will need to replace X:X by the proper column and X# by the proper range.
It took about 30 seconds using the macro recorder to get that code.