I created a Loop to find each iteration of some HTML code and return the e-mail data as a string. What we are looking for is:
'Jibberish HTML Code
<p><b><font color="#000066" size="3" face="Arial">Delivery has failed to these recipients or groups:</font></b></p>
<font color="#000000" size="2" face="Tahoma"><p>last.first#location.company.com<br>
'Jibberish HTML Code
<p><b><font color="#000066" size="3" face="Arial">Delivery has failed to these recipients or groups:</font></b></p>
<font color="#000000" size="2" face="Tahoma"><p>last.first#location.company.com<br>
'Jibberish HTML Code
<p><b><font color="#000066" size="3" face="Arial">Delivery has failed to these recipients or groups:</font></b></p>
<font color="#000000" size="2" face="Tahoma"><p>last.first#location.company.com<br>
This code will find the FIRST iteration and as of right now the Loop creates an infite loop on the first found value (doesn't move to next found value:
Sub RevisedFindIt()
' Purpose: display the text between (but not including)
' the words "Title" and "Address" if they both appear.
Dim rng1 As Range
Dim rng2 As Range
Dim strTheText As String
Set rng1 = ActiveDocument.Range
With rng1.Find
.Execute FindText:="<font color=" & Chr(34) & "#000000" & Chr(34) & " size=" & Chr(34) & "2" & Chr(34) & " face=" & Chr(34) & "Tahoma" & Chr(34) & "><p><a href=" & Chr(34) & "mailto:", Forward:=True
Do While .Found
Set rng2 = ActiveDocument.Range(rng1.End, ActiveDocument.Range.End)
If rng2.Find.Execute(FindText:=Chr(34) & ">") Then
strTheText = ActiveDocument.Range(rng1.End, rng2.Start).Text
'Debug.Print strTheText
CreateObject("Excel.Application").Run "'TestExport.xlsm'!RunIt", strTheText
End If
Loop
End With
End Sub
The data is being passed to an Excel Sub:
Public Sub RunIt(strTheText As String)
Dim LastRow As Long
Debug.Print strTheText & "Test"
LastRow = ActiveWorkbook.ActiveSheet.Range("A" & ActiveWorkbook.ActiveSheet.Rows.Count).End(xlUp).Row + 1
ActiveWorkbook.ActiveSheet.Range("A" & LastRow).Value = strTheText
End Sub
How do I get the search to skip to the next iteration in Word VBA?
Solved by changing the rng1 mid loop and refinding the data:
Sub RevisedFindIt()
' Purpose: display the text between (but not including) two strings
Dim rng1 As Range
Dim rng2 As Range
Dim strTheText As String
Set rng1 = ActiveDocument.Range
Do
With rng1.Find
.Execute FindText:="<font color=" & Chr(34) & "#000000" & Chr(34) & " size=" & Chr(34) & "2" & Chr(34) & " face=" & Chr(34) & "Tahoma" & Chr(34) & "><p><a href=" & Chr(34) & "mailto:"
If .Found Then
Set rng2 = ActiveDocument.Range(rng1.End, ActiveDocument.Range.End)
If rng2.Find.Execute(FindText:=Chr(34) & ">") Then
strTheText = ActiveDocument.Range(rng1.End, rng2.Start).Text
'Debug.Print strTheText
CreateObject("Excel.Application").Run "'TestExport.xlsm'!RunIt", strTheText
End If
Set rng1 = ActiveDocument.Range(rng2.End, ActiveDocument.Range.End)
Else
Exit Do
End If
End With
Loop
End Sub
In fact, all you need is simple:
.execute
before your only
End If
Your problem looks to be because the value of rng1.Found never changes once you're inside the Do While .Found loop. The .Found in Do While .Found refers to rng1.Found because of the With rng1.Find statement that contains it.
Sub M_snb()
sn = Split(Replace(Join(Filter(Split(LCase(ActiveDocument.Content), Chr(34)), "mailto:"), "|"), "mailto:", ""), "|")
With CreateObject("Excel.Application")
.workbooks.Add().sheets(1).Cells(1).Resize(UBound(sn) + 1) = .Application.transpose(sn)
.Visible = True
End With
End Sub
Related
I am trying to add a document to an email as a PDF. I am trying to change the file name to include the date which is stored in a table in the Word document.
I can create the email but the script gives me an error when it tries to export.
How can I attach the file as a PDF with a file name with the date pulled from the table in Word?
Sub CommandButton1_Click()
Dim OL As Object
Dim EmailItem As Object
Dim Doc As Document
Dim DateField As String
Dim desktoploc As String
Dim mypath As String
Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Doc = ActiveDocument
Doc.Save
'Pull date from table and change format
DateField = Format(Doc.Content.Tables(1).Cell(1, 4).Range.Text, "yyyymmdd")
'Pull line number and subject names from table 1 and table 2 in word to add to subject.
Dim linenum As Word.Range, subject1 As Word.Range, subjec2 As Word.Range
'Need to remove hidden line breaks from tables in word in order to fit on subject line of email
Set linenum = Doc.Content.Tables(1).Cell(1, 2).Range
linenum.MoveEnd unit:=wdCharacter, Count:=-1
Set subject1 = Doc.Content.Tables(2).Cell(2, 1).Range
subject1.MoveEnd unit:=wdCharacter, Count:=-1
Set subjec2 = Doc.Content.Tables(2).Cell(3, 1).Range
subjec2.MoveEnd unit:=wdCharacter, Count:=-1
'Create PDF File
Dim file_name As String
Dim NewFileName As String
NewFileName = "Load Limits Subjects " & linenum & " " & DateField
file_name = ActiveDocument.Path & "\" & Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1) & NewFileName & ".pdf"
'This is where I keep getting the error.....
ActiveDocument.ExportAsFixedFormat OutputFileName:=file_name, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, Item:= _
wdExportDocumentContent, IncludeDocProps:=False, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
With EmailItem
.Display
.Subject = "Limit Notification - Subject " & linenum & " #line #" & linenum & _
" #" & subject1.Text & " #" & subjec2.Text & vbCrLf
.Body = "Please see the attached Limit Notification for Subject " & linenum.Text & vbCrLf & _
"" & vbCrLf & _
"Let me know if you have any questions." & vbCrLf & _
"" & vbCrLf & _
"Thank you," & vbCrLf & vbCrLf & _
"INSERT SIGNATURE HERE"
'Update Recipient List here:
.To = "LineEmail#email.com; "
.CC = "Another Email#demail.com"
'.Importance = olImportanceNormal
.Attachments.Add Doc.FullName
End With
End Sub
Your code has multiple flaws, including:
Your DateField string is trying to convert something that includes a table cell's end-of-cell marker into an ISO-format date
Your code is not validating the NewFileName string as a filename.
Your code is trying to to attach the document to the email, not the pdf.
Your code is referencing ActiveDocument (which may no longer be the same as Doc) when creating path etc. for the new filename.
Try something along the lines of:
Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim OL As Object
Dim EmailItem As Object
Dim Doc As Document
Dim Rng As Range
Dim i As Long
Dim NewFileName As String
Dim MailSubject As String
Dim MailBody As String
Const StrNoChr As String = """*./\:?|"
NewFileName = " Load Limits Subjects "
MailSubject = "Limit Notification - Subject "
MailBody = "Please see the attached Limit Notification for Subject "
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Doc = ActiveDocument
With Doc
.Save
Set Rng = .Tables(1).Cell(1, 2).Range
Rng.End = Rng.End - 1
NewFileName = NewFileName & Rng.Text & " "
MailSubject = MailSubject & Rng.Text & " #line #" & Rng.Text & " #"
MailBody = MailBody & Rng.Text
Set Rng = .Tables(1).Cell(1, 4).Range
Rng.End = Rng.End - 1
NewFileName = NewFileName & Format(Rng.Text, "YYYYMMDD")
Set Rng = .Tables(2).Cell(2, 1).Range
Rng.End = Rng.End - 1
MailSubject = MailSubject & Rng.Text
Set Rng = .Tables(2).Cell(3, 1).Range
Rng.End = Rng.End - 1
MailSubject = MailSubject & Rng.Text
For i = 1 To Len(StrNoChr)
NewFileName = Replace(NewFileName, Mid(StrNoChr, i, 1), "_")
Next
NewFileName = Split(.FullName, ".doc")(0) & NewFileName & ".pdf"
SaveAs2 FileName:=NewFileName, FileFormat:=wdFormatPDF, AddToRecentFiles:=False
End With
MailBody = MailBody & vbCrLf & _
"" & vbCrLf & _
"Let me know if you have any questions." & vbCrLf & _
"" & vbCrLf & _
"Thank you," & vbCrLf & vbCrLf & _
"INSERT SIGNATURE HERE"
With EmailItem
.Display
.Subject = MailSubject
.Body = MailBody
'Update Recipient List here:
.To = "LineEmail#email.com; "
.CC = "Another Email#demail.com"
'.Importance = olImportanceNormal
.Attachments.Add NewFileName
End With
End Sub
I using a VBA code to batch find and replace highlighted text. The macro finds and replaces the words in the document. It works well with a few number of highlighted text on a small document (1-2 pages). However, when I use this macro on a large documents which has over a 100 pages, Microsoft word crashed and becomes unresponsive so I have to forced to quit.
The code is to help make it easy to redact information. I am replacing the highlight text which occur also in tables with XXXXX and highlighted black.
Does anyone have any tips to make the code more efficient?
Here is the code
Sub FindandReplaceHighlight()
Dim strFindColor As String
Dim strReplaceColor As String
Dim strText As String
Dim objDoc As Document
Dim objRange As Range
Application.ScreenUpdating = False
Set objDoc = ActiveDocument
strFindColor = InputBox("Specify a color (enter the value):", "Specify Highlight Color")
strReplaceColor = InputBox("Specify a new color (enter the value):", "New Highlight Color")
strText = InputBox("Specify a new text (enter the value):", "New Text")
With Selection
.HomeKey Unit:=wdStory
With Selection.Find
.Highlight = True
Do While .Execute
If Selection.Range.HighlightColorIndex = strFindColor Then
Set objRange = Selection.Range
objRange.HighlightColorIndex = strReplaceColor
objRange.Text = strText
objRange.Font.ColorIndex = wdBlack
Selection.Collapse wdCollapseEnd
End If
Loop
End With
End With
Application.ScreenUpdating = True
End Sub
Try:
Sub FindandReplaceHighlight()
Application.ScreenUpdating = False
Dim ClrFnd As Long, ClrRep As Long, strTxt As String
Const StrColors As String = vbCr & _
" 1 Black" & vbCr & _
" 2 Blue" & vbCr & _
" 3 Turquoise" & vbCr & _
" 4 Bright Green" & vbCr & _
" 5 Pink" & vbCr & _
" 6 Red" & vbCr & _
" 7 Yellow" & vbCr & _
" 8 White" & vbCr & _
" 9 Dark Blue" & vbCr & _
"10 Teal" & vbCr & _
"11 Green" & vbCr & _
"12 Violet" & vbCr & _
"13 Dark Red" & vbCr & _
"14 Dark Yellow" & vbCr & _
"15 Gray 50" & vbCr & _
"16 Gray 25%"
ClrFnd = InputBox("Specify the old color (enter the value):" & StrColors, "Specify Highlight Color")
ClrRep = InputBox("Specify the new color (enter the value):" & StrColors, "New Highlight Color")
strTxt = InputBox("Specify the new text (enter the value):", "New Text")
With ActiveDocument
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Highlight = True
.Forward = True
.Wrap = wdFindStop
End With
Do While .Find.Execute
If .HighlightColorIndex = ClrFnd Then
.HighlightColorIndex = ClrRep
.Text = strTxt
.Font.ColorIndex = wdBlack
.Collapse wdCollapseEnd
End If
Loop
End With
End With
Application.ScreenUpdating = True
End Sub
I am looking to bold every second line entry on a word document that receives input from an excel spreadsheet. In other words, I want the resulting word document to have each line containing 'ID:' to contain bold text. I've looked into other examples but I keep getting errors such as mismatch.
Sub ExceltoWord_TestEnvironment()
Dim wApp As Object
Dim wDoc As Object
Dim strSearchTerm
Dim FirstMatch As Range
Dim FirstAddress
Dim intMyVal As String
Dim lngLastRow As Long
Dim strRowNoList As String
Dim intPlaceHolder As Integer
Set wApp = CreateObject("Word.Application")
Set wDoc = CreateObject("Word.Document")
wApp.Visible = True
Set wDoc = wApp.Documents.Add
wDoc.Range.ParagraphFormat.SpaceBefore = 0
wDoc.Range.ParagraphFormat.SpaceAfter = 0
strSearchTerm = InputBox("Please enter the date to find", "Search criteria")
If strSearchTerm <> "" Then
Set FirstMatch = ActiveSheet.Cells.Find(strSearchTerm, LookAt:=xlPart, MatchCase:=False)
If FirstMatch Is Nothing Then
MsgBox "That date could not be found"
Else
FirstAddress = FirstMatch.Address
intMyVal = strSearchTerm
lngLastRow = Cells(Rows.Count, "F").End(xlUp).Row 'Search Column F, change as required.
For Each cell In Range("F1:F" & lngLastRow) 'F is column
If InStr(1, cell.Value, intMyVal) Then
If strRowNoList = "" Then
strRowNoList = strRowNoList & cell.Row
intPlaceHolder = cell.Row
wDoc.Content.InsertAfter "Group: " & Cells(intPlaceHolder, 3) & vbNewLine
wDoc.Content.InsertAfter "ID: " & Cells(intPlaceHolder, 2) & vbNewLine
wDoc.Content.InsertAfter "Name: " & vbNewLine & vbNewLine
Else
strRowNoList = strRowNoList & ", " & cell.Row
intPlaceHolder = cell.Row
wDoc.Content.InsertAfter "Group: " & Cells(intPlaceHolder, 3) & vbNewLine
wDoc.Content.InsertAfter "ID: " & Cells(intPlaceHolder, 2) & vbNewLine
wDoc.Content.InsertAfter "Name: " & vbNewLine & vbNewLine
End If
Next cell
MsgBox strRowNoList
While Not FirstMatch Is Nothing
Set FirstMatch = ActiveSheet.Cells.FindNext(FirstMatch)
If FirstMatch.Address = FirstAddress Then
Set FirstMatch = Nothing
End If
Wend
End If
End If
End Sub
Example:
Group: Group A
ID: 123456
Name: Jon Snow
Group: Group B
ID: 789101
Name: Samwell Tarly
I was able to find a work around. Thought I would post it here to help others. Sorry my code isn't as clean as I would like it to be. Copying and pasting didn't quite match up.
Sub ExceltoWord_TestEnvironment()
Dim wApp As Object
Dim wDoc As Object
Dim strSearchTerm
Dim FirstMatch As Range
Dim FirstAddress
Dim intMyVal As String
Dim lngLastRow As Long
Dim strRowNoList As String
Dim intPlaceHolder As Integer
Set wApp = CreateObject("Word.Application")
Set wDoc = CreateObject("Word.Document")
wApp.Visible = True
Set wDoc = wApp.Documents.Add
wDoc.Range.ParagraphFormat.SpaceBefore = 0
wDoc.Range.ParagraphFormat.SpaceAfter = 0
strSearchTerm = InputBox("Please enter the date to find", "Search criteria")
If strSearchTerm <> "" Then
Set FirstMatch = ActiveSheet.Cells.Find(strSearchTerm, LookAt:=xlPart, MatchCase:=False)
If FirstMatch Is Nothing Then
MsgBox "That date could not be found"
Else
FirstAddress = FirstMatch.Address
intMyVal = strSearchTerm
lngLastRow = Cells(Rows.Count, "F").End(xlUp).Row 'Search Column F, change as required.
For Each cell In Range("F1:F" & lngLastRow) 'F is column
If InStr(1, cell.Value, intMyVal) Then
If strRowNoList = "" Then
strRowNoList = strRowNoList & cell.Row
intPlaceHolder = cell.Row
intParaCount = wDoc.Paragraphs.Count
i = 2
Set objParagraph = wDoc.Paragraphs(i).Range
With objParagraph
.Font.Bold = True
End With
wDoc.Content.InsertAfter "Group: " & Cells(intPlaceHolder, 3) & vbNewLine
wDoc.Content.InsertAfter "ID: " & Cells(intPlaceHolder, 2) & vbNewLine
wDoc.Content.InsertAfter "Name: " & vbNewLine & vbNewLine
i = i + 4 'paragraph number
Else
strRowNoList = strRowNoList & ", " & cell.Row
intPlaceHolder = cell.Row
wDoc.Content.InsertAfter "Group: " & Cells(intPlaceHolder, 3) & vbNewLine
wDoc.Content.InsertAfter "ID: " & Cells(intPlaceHolder, 2) & vbNewLine
wDoc.Content.InsertAfter "Name: " & vbNewLine & vbNewLine
i = i + 4
End If
Next cell
MsgBox strRowNoList
While Not FirstMatch Is Nothing
Set FirstMatch = ActiveSheet.Cells.FindNext(FirstMatch)
If FirstMatch.Address = FirstAddress Then
Set FirstMatch = Nothing
End If
Wend
End If
End If
End Sub
The code utilizes .paragraphs() where 'i' is the paragraph you want to bold:
i = 2
Set objParagraph = wDoc.Paragraphs(i).Range
With objParagraph
.Font.Bold = True
End With
And the difference in paragraphs is added after each iteration
i = i + 4 'paragraph number
I currently have to send multiple letters out at one time and often replace only 1 or two words within a cell. The problem is that I need those words to be bolded and it would be tedious to use this macro individually on 150 worksheets. I am very new to coding and have tried to search online to edit this code to loop through all of the worksheets, but everything I try seems to only change the current sheet I am on. Below is my current code with what I thought would cause the loop, but instead of looping through the worksheets it seems to only loop through the single worksheet I am on, asking if I would like to bold another word on that sheet.
Origanal code:
Sub FindAndBold()
Dim ws As Worksheet
Dim sFind As String
Dim rCell As Range
Dim rng As Range
Dim lCount As Long
Dim iLen As Integer
Dim iFind As Integer
Dim iStart As Integer
On Error Resume Next
Set rng = ActiveSheet.UsedRange. _
SpecialCells(xlCellTypeConstants, xlTextValues)
On Error GoTo ErrHandler
If rng Is Nothing Then
MsgBox "There are no cells with text"
GoTo ExitHandler
End If
sFind = InputBox( _
Prompt:="What do you want to BOLD?", _
Title:="Text to Bold")
If sFind = "" Then
MsgBox "No text was listed"
GoTo ExitHandler
End If
iLen = Len(sFind)
lCount = 0
For Each rCell In rng
With rCell
iFind = InStr(.Value, sFind)
Do While iFind > 0
.Characters(iFind, iLen).Font.Bold = True
lCount = lCount + 1
iStart = iFind + iLen
iFind = InStr(iStart, .Value, sFind)
Loop
End With
Next
If lCount = 0 Then
MsgBox "There were no occurrences of" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "to bold."
ElseIf lCount = 1 Then
MsgBox "One occurrence of" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "was made bold."
Else
MsgBox lCount & " occurrences of" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "were made bold."
End If
ExitHandler:
Set rCell = Nothing
Set rng = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
My most recent attempt:
Sub FindAndBold()
Dim ws As Worksheet
Dim sFind As String
Dim rCell As Range
Dim rng As Range
Dim lCount As Long
Dim iLen As Integer
Dim iFind As Integer
Dim iStart As Integer
For Each ws In ActiveWorkbook.Worksheets
On Error Resume Next
Set rng = ActiveSheet.UsedRange. _
SpecialCells(xlCellTypeConstants, xlTextValues)
On Error GoTo ErrHandler
If rng Is Nothing Then
MsgBox "There are no cells with text"
GoTo ExitHandler
End If
sFind = InputBox( _
Prompt:="What do you want to BOLD?", _
Title:="Text to Bold")
If sFind = "" Then
MsgBox "No text was listed"
GoTo ExitHandler
End If
iLen = Len(sFind)
lCount = 0
For Each rCell In rng
With rCell
iFind = InStr(.Value, sFind)
Do While iFind > 0
.Characters(iFind, iLen).Font.Bold = True
lCount = lCount + 1
iStart = iFind + iLen
iFind = InStr(iStart, .Value, sFind)
Loop
End With
Next
If lCount = 0 Then
MsgBox "There were no occurrences of" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "to bold."
ElseIf lCount = 1 Then
MsgBox "One occurrence of" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "was made bold."
Else
MsgBox lCount & " occurrences of" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "were made bold."
End If
Next ws
ExitHandler:
Set rCell = Nothing
Set rng = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
Corrected working code provided provided by YowE3K:
Sub FindAndBold()
Dim ws As Worksheet
Dim sFind As String
Dim rCell As Range
Dim rng As Range
Dim lCount As Long
Dim iLen As Integer
Dim iFind As Integer
Dim iStart As Integer
For Each ws In ActiveWorkbook.Worksheets
Set rng = Nothing
Set rng = ws.UsedRange.SpecialCells(xlCellTypeConstants, xlTextValues)
If rng Is Nothing Then
MsgBox "There are no cells with text"
GoTo ExitHandler
End If
sFind = InputBox( _
Prompt:="What do you want to BOLD?", _
Title:="Text to Bold")
If sFind = "" Then
MsgBox "No text was listed"
GoTo ExitHandler
End If
iLen = Len(sFind)
lCount = 0
For Each rCell In rng
With rCell
iFind = InStr(.Value, sFind)
Do While iFind > 0
.Characters(iFind, iLen).Font.Bold = True
lCount = lCount + 1
iStart = iFind + iLen
iFind = InStr(iStart, .Value, sFind)
Loop
End With
Next
If lCount = 0 Then
MsgBox "There were no occurrences of" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "to bold on worksheet '" & ws.Name & "'."
ElseIf lCount = 1 Then
MsgBox "One occurrence of" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "was made bold on worksheet '" & ws.Name & "'."
Else
MsgBox lCount & " occurrences of" & _
vbCrLf & "' " & sFind & " '" & _
vbCrLf & "were made bold on worksheet '" & ws.Name & "'."
End If
Next ws
ExitHandler:
Set rCell = Nothing
Set rng = Nothing
Exit Sub
End Sub
You are setting up a loop to go through each worksheet (using ws as your reference to the sheet currently being processed), but then processing a range on the ActiveSheet. Use ws instead of ActiveSheet.
You should also set rng to Nothing before attempting to set it to the UsedRange.SpecialCells or else, if that crashes, your If rng Is Nothing Then statement won't work (because rng will still be set to whatever it was set to on the previous iteration through the loop).
'...
For Each ws In ActiveWorkbook.Worksheets
Set rng = Nothing
On Error Resume Next
Set rng = ws.UsedRange.SpecialCells(xlCellTypeConstants, xlTextValues)
On Error GoTo ErrHandler
If rng Is Nothing Then
'...
Sub SearchOnWorksheets()
Dim sPrompt As String
Dim msgTrap As VbMsgBoxResult
Dim xWBName As String
Dim xWBAbiertos As String
Dim wSheet As Worksheet
Dim wBook As Workbook
Dim rFound As Range
Dim bFound As Boolean
If Workbooks.Count >= 2 Then
For Each wBook In Application.Workbooks
xWBAbiertos = xWBAbiertos & "[ " & wBook.Name & " ]" & vbCrLf
Next
For Each wBook In Application.Workbooks
For Each wSheet In wBook.Worksheets
Set rFound = Nothing
Set rFound = wSheet.Cells.Find(What:="raya", After:=wSheet.Cells(1, 1), _
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not rFound Is Nothing Then
bFound = True
xWBName = wBook.Name & vbCrLf
Exit For
End If
Next wSheet
If bFound = True Then Exit For
Next wBook
sPrompt = "Archivos Excel abiertos:" & vbNewLine & _
vbNewLine & xWBAbiertos & vbNewLine & _
vbNewLine & "El archivo de donde se extraerán los gastos es:" & vbNewLine & _
vbNewLine & xWBName & vbNewLine & _
vbNewLine & ""
msgTrap = MsgBox(sPrompt, vbYesNo + vbExclamation, "CUBIMSA")
Select Case msgTrap
Case vbYes
Exit Sub
Case vbNo
Exit Sub
End Select
Else
Call MsgBox("THERE IS NO OPENED ARCHIVE." & vbNewLine & _
vbNewLine & "OPEN ARCHIVE", vbCritical, "ERROR")
Exit Sub
End If
End Sub
In this message appears the file "gastos.xls" because the code looks for the word "raya" in every opened workbook, but I need it to show all the workbooks that met this criteria.
Or maybe if it is possible in all the workbooks look for the sheet "Raya Semanal".
And I need to use this workbook to extract some information, how can I convert this string on something I can copy and paste in other workbook?
something like Workbooks("gastos.xls").Sheets("Raya Semanal").Range("Z16").Value
I think you are asking for 2 things:
I need it to show all the workbooks that met this criteria
In order to record all foundings for all the WBs you would need to change this line xWBName = wBook.Name & vbCrLf to xWBName = wBook.Name & vbCrLf & xWBName
And I need to use this workbook to extract some information, how can I convert this string on something I can copy and paste in other workbook?
I would use the split Function
Like so:
Dim ItemArray as Variant
For Each ItemArray in Split(xWBName ,vbCrlf) 'I may be wrong and probably you should use Chr(10) instead of vbcrlf
Workbooks(Cstr(ItemArray)).Sheets("Raya Semanal").Range("Z16").Value
Next ItemArray