I am using Office 365 on a Windows 10 64-bit pc.
I have a Word document with a table into which I want to copy elements from an Excel document. The elements are a) text from its cell, b) a hyperlink from its cell and c) images from a list of images.
The first two tasks are performed successfully by the following sub:
Sub ImportFromExcel()
Dim RowNo As Long, RowTarget As Long
Dim RowFirst As Long, RowLast As Long
Dim strContent As String, strLink As String, strDisplay As String
Dim xlAppl As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim xlSheet As New Excel.Worksheet
Dim ExcelFileName As String
Dim tbl As Word.Table
On Error GoTo Finish
ExcelFileName = "C:\MyPath\MyExcelDoc.xlsm"
Set xlAppl = CreateObject("Excel.Application")
xlAppl.Application.Visible = False
xlAppl.Workbooks.Open ExcelFileName
Set xlBook = xlAppl.ActiveWorkbook
Set xlSheet = xlBook.Worksheets("Titan")
Set tbl = ActiveDocument.Tables(1)
RowFirst = 6: RowLast = 19
For RowNo = RowFirst To RowLast
RowTarget = RowNo - RowFirst + 1
strContent = xlSheet.Cells(RowNo, 5).Value
tbl.Cell(RowTarget, 1).Range.Text = strContent
strDisplay = xlSheet.Cells(RowNo, 3).Value
tbl.Cell(RowTarget, 3).Range.Text = strContent
strLink = xlSheet.Cells(RowNo, 3).Hyperlinks(1).Address
InsertHyperlinkInTable tbl, RowTarget, 3, strLink, strDisplay
' CopyImageFromExcelToWord xlSheet, RowTarget, tbl
Next RowNo
Finish:
xlAppl.ActiveWorkbook.Close False ' Word will not freeze at this point
xlAppl.Quit
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlAppl = Nothing
End Sub
I copy the hyperlink by reading its address and caption and then recreating it in Word.
Also from Word I can select a give image by way of its index using the first two active lines of the following sub:
Sub CopyImageFromExcelToWord(xlSheet As Excel.Worksheet, imgNo As Long, tbl As Word.Table)
Dim strId As String
' Syntax at https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.select
strId = "Picture " & CStr(2 * imgNo)
xlSheet.Shapes.Range(Array(strId)).Select
' Missing link !
With tbl.Cell(1, 4)
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.VerticalAlignment = wdCellAlignVerticalCenter
.Select
End With
Selection.PasteAndFormat (wdFormatOriginalFormatting)
End Sub
An image residing in the clipboard can be inserted into Word using the last six lines.
But I have not found out how to copy the image I selected in the Excel document to the clipboard with a Word macro.
Can this be done somehow?
Can the copying of the hyperlink be performed in a smarter way?
Try
Sub CopyImageFromExcelToWord(xlSheet As Excel.Worksheet, imgNo As Long, tbl As Word.Table)
Dim strId As String
' Syntax at https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.select
strId = "Picture " & CStr(2 * imgNo)
xlSheet.Shapes.Range(Array(strId)).Item(1).Copy
With tbl.Cell(1, 4)
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.VerticalAlignment = wdCellAlignVerticalCenter
.Range.PasteAndFormat wdFormatOriginalFormatting
End With
End Sub
I have a client who is hand holding a bunch of worksheets that should be standardized. They are created from importing CSV files. Basically, I need to replace the current manual sheets while they are being referenced from another tab without breaking the current references.
I've reduced the problem to a single workbook with 2 sheets. Sheet1 cell A1 references Sheet2 cell A1 which holds the string "Sheet2A1CellData"
Everything commented out below has been tried including Application.Volatile and Application.Calculation.
Option Explicit
Sub TestSheet2Delete()
Dim TmpSheet2 As Worksheet: Set TmpSheet2 = Sheets("Sheet2")
'Application.Volatile
If TmpSheet2 Is Nothing Then
Exit Sub
End If
'Application.Calculation = False
Application.DisplayAlerts = False
TmpSheet2.Delete
Application.DisplayAlerts = True
Set TmpSheet2 = Worksheets.Add(After:=Sheets("Sheet1"))
If TmpSheet2 Is Nothing Then
Exit Sub
End If
TmpSheet2.Name = "Sheet2"
TmpSheet2.Range("A1").Value = "Sheet2A1CellData"
'Application.Calculation = True
End Sub
Sheet1 A1 was originally =Sheet2!A1. When I run the function above from the VBE, Sheet1 cell A1 is set to =#REF!A1.
How can I keep the reference valid after the sheet has been replaced?
Obviously, the real world problem is much larger and re-importing CSV data requires updating 132,000 cells. 6000 rows x 22 Columns.
Thanks for any help.
Thank you presenting a real good question.
First of all disclaimer: This is not an direct solution but and workaround we had to adopt years back.
Exactly similar problem problem had been encountered in my workplace (literally made us to pull out our hairs), and we also tried to go for iNDIRECT. But since the formulas in the working sheets are complex we failed to replace them with INDIRECT. So instead of lengthy manual replacement of the hundreds of Formulas in the working sheet, we used to insert a temp Sheet and change the formulas reference to that sheet. After importing new sheet and renaming it as old sheet's name, formulas were reverted back to original.
I tried to reproduce the code used (since I don't have access to same files now). We only used the Sub ChangeFormulas, Here I used the same in line with your code.
Option Explicit
Sub TestSheet2Delete()
Dim Wb As Workbook
Dim Ws As Worksheet, Ws1 As Worksheet, Ws2 As Worksheet
Dim Xstr As String, Ystr As String
Set Wb = ThisWorkbook
Set Ws = Wb.Sheets("Sheet1")
Xstr = "Sheet2"
Ystr = "TempSheetX"
Set Ws1 = Wb.Sheets(Xstr)
Set Ws2 = Worksheets.Add(After:=Ws)
Ws2.Name = Ystr
DoEvents
ChangeFormulas Ws, Xstr, Ystr
Application.DisplayAlerts = False
Ws1.Delete
' Now again add another sheet with Old name and change formulas back to Original
Set Ws1 = Worksheets.Add(After:=Ws)
Ws1.Name = Xstr
DoEvents
ChangeFormulas Ws, Ystr, Xstr
Ws2.Delete
Application.DisplayAlerts = True
End Sub
Sub ChangeFormulas(Ws As Worksheet, Xstr As String, Ystr As String)
Dim Rng As Range, C As Range, FirstAddress As String
Set Rng = Ws.UsedRange
With Rng
Set C = .Find(What:=Xstr, LookIn:=xlFormulas)
If Not C Is Nothing Then
FirstAddress = C.Address
Do
C.Formula = Replace(C.Formula, Xstr, Ystr)
Set C = .FindNext(C)
If C Is Nothing Then Exit Do
If C.Address = FirstAddress Then Exit Do
Loop
End If
End With
End Sub
Another simplest workaround is not to delete the Sheet at all and import the CSV and copy the full sheet onto the sheet in question. However This fully depends on actual working conditions involving CSV and all.
AFTER I posted (of course :-)), this link came up on the right: Preserve references that recommends using INDIRECT. I have now changed Sheet1 A1 to =INDIRECT("Sheet2!"&"A1").
I am not certain why the named ranges suggested in the link are needed. The indirect call above seems to work without a named range.
If this works in the larger project, I will mark this as complete.
My original answer did not work for non-contiguous cells. However, I really like the Range to Variants and then back to Range pattern. Very fast. So I rewrote my original answer into more reusable code that tests using non-contiguous cells.
Function PreserveFormulaeInVariantArr(ByVal aWorksheet As Worksheet, _
ByVal aIsNoFormulaErr As Boolean, _
ByRef aErrStr As String) As Variant
Dim TmpRange As Range
Dim TmpAreaCnt As Long
Dim TmpVarArr As Variant
Dim TmpAreaVarArr As Variant
PreserveFormulaeInVariantArr = Empty
If aWorksheet Is Nothing Then
aErrStr = "PreserveFormulaeInVariantArr: Worksheet is Nothing."
Exit Function
End If
Err.Clear
On Error Resume Next
Set TmpRange = aWorksheet.Cells.SpecialCells(xlCellTypeFormulas)
If Err.Number <> 0 Then 'No Formulae.
PreserveFormulaeInVariantArr = Empty
If aIsNoFormulaErr Then
aErrStr = "PreserveFormulaeInVariantArr: No cells with formulae."
End If
Exit Function
End If
TmpAreaVarArr = Empty
On Error GoTo ErrLabel
ReDim TmpVarArr(1 To TmpRange.Areas.Count, 1 To 2)
For TmpAreaCnt = LBound(TmpVarArr) To UBound(TmpVarArr)
TmpVarArr(TmpAreaCnt, 1) = TmpRange.Areas(TmpAreaCnt).Address 'Set 1st Element to Range
TmpAreaVarArr = TmpRange.Areas(TmpAreaCnt).Formula 'Left TmpArrVarArr for Debugging
TmpVarArr(TmpAreaCnt, 2) = TmpAreaVarArr 'Creates Jagged Array
Next TmpAreaCnt
PreserveFormulaeInVariantArr = TmpVarArr
Exit Function
ErrLabel:
aErrStr = "PreserveFormulaeInVariantArr - Error Number: " + CStr(Err.Number) + " Error Description: " + Err.Description
End Function
Function RestoreFormulaeFromVariantArr(ByVal aWorksheet As Worksheet, _
ByVal aIsEmptyAreaVarArrError As Boolean, _
ByVal aAreaVarArr As Variant, _
ByRef aErrStr As String) As Boolean
Dim TmpVarArrCnt As Long
Dim TmpRange As Range
Dim TmpDim1Var As Variant
Dim TmpDim2Var As Variant
Dim TmpDim2Cnt As Long
Dim TmpDim2UBound As Long
RestoreFormulaeFromVariantArr = False
On Error GoTo ErrLabel
If aWorksheet Is Nothing Then
Exit Function
End If
If IsEmpty(aAreaVarArr) Then
If aIsEmptyAreaVarArrError Then
aErrStr = "RestoreFormulaeFromVariantArr: Empty array passed."
Else
RestoreFormulaeFromVariantArr = True
End If
Exit Function
End If
For TmpVarArrCnt = 1 To UBound(aAreaVarArr)
TmpDim1Var = aAreaVarArr(TmpVarArrCnt, 1) 'This is always the range.
TmpDim2Var = aAreaVarArr(TmpVarArrCnt, 2) 'This can be a Variant or Variant Array
aWorksheet.Range(TmpDim1Var).Formula = TmpDim2Var
Next TmpVarArrCnt
RestoreFormulaeFromVariantArr = True
Exit Function
ErrLabel:
aErrStr = "PreserveFormulaeInVariantArr - Error Number: " + CStr(Err.Number) + " Error Description: " + Err.Description
End Function
Sub TestPreserveFormulaeInVariantArr()
Dim TmpPreserveFormulaeArr As Variant
Dim TmpErrStr As String
Dim TmpIsNoFormulaErr As Boolean: TmpIsNoFormulaErr = True 'Change If Desired
Dim TmpEmptySheet1 As Boolean: TmpEmptySheet1 = False 'Change If Desired
Dim TmpSheet1 As Worksheet: Set TmpSheet1 = Sheets("Sheet1")
Dim TmpSheet2 As Worksheet
Err.Clear
On Error Resume Next
Set TmpSheet2 = Sheets("Sheet2")
On Error GoTo 0
'Always Delete Sheet2
If (TmpSheet2 Is Nothing) = False Then
Application.DisplayAlerts = False
TmpSheet2.Delete
Application.DisplayAlerts = True
Set TmpSheet2 = Nothing
End If
If TmpSheet2 Is Nothing Then
Set TmpSheet2 = Worksheets.Add(After:=Sheets("Sheet1"))
TmpSheet2.Name = "Sheet2"
TmpSheet2.Range("A1") = "Sheet2A1"
TmpSheet2.Range("B1") = "Sheet2A1"
TmpSheet2.Range("C4") = "Sheet2C4"
If TmpEmptySheet1 Then
TmpSheet1.Cells.ClearContents
Else
TmpSheet1.Range("A1").Formula = "=Sheet2!A1"
TmpSheet1.Range("B1").Formula = "=Sheet2!B1"
TmpSheet1.Range("C4").Formula = "=Sheet2!C4"
End If
End If
TmpPreserveFormulaeArr = PreserveFormulaeInVariantArr(TmpSheet1, TmpIsNoFormulaErr, TmpErrStr)
If TmpErrStr <> "" Then
MsgBox TmpErrStr
Exit Sub
End If
'Break Formulae and Cause #Ref Violation
Application.DisplayAlerts = False
TmpSheet2.Delete
Application.DisplayAlerts = True
'Add Sheet2 Back
Set TmpSheet2 = Worksheets.Add(After:=Sheets("Sheet1"))
TmpSheet2.Name = "Sheet2"
TmpSheet2.Range("A1") = "Sheet2A1"
TmpSheet2.Range("B1") = "Sheet2A1"
TmpSheet2.Range("C4") = "Sheet2C4"
'Restore Formulas Back to Sheet1
If RestoreFormulaeFromVariantArr(TmpSheet1, TmpIsNoFormulaErr, TmpPreserveFormulaeArr, TmpErrStr) = False Then
MsgBox TmpErrStr
Exit Sub
End If
End Sub
The TestPreserveFormulaeInVariantArr can be run in the VBE with options to set empty values. Any comments appreciated.
I have been using an Excel VBA macro to add images to my spreadsheet lists from a folder on our office server. The list exports from my database software with the containing folder and image name in Column A (e.g. 038/19761809.jpg). I now need to send these documents to persons outside of my office without access to our server so I am trying to switch from using ActiveSheet.Pictures.Insert to using the more correct ActiveSheet.Shapes.AddPicture. The goal is to have the image files embed in the document rather than just linking to the files on our office server.
This code (using Pictures.Insert) inserts the images as links. When I email the spreadsheet to off-site users, the linked images "break" as recipient's computer cannot find them (because their computer is not on our local network).
Sub InsertPictures()
Dim MyRange As String
Dim picname As String
Dim mySelectRange As String
Dim rcell As Range
Dim IntInstr As Integer
Dim Mypath As String
Mypath = "S:\pp4\images\"
MyRange = "A2:A275"
Range(MyRange).Select
For Each rcell In Selection.Cells
If Len(rcell.Value) > 0 Then
picname = Mypath & rcell.Value
mySelectRange = Replace(MyRange, "B", "A")
IntInstr = InStr(mySelectRange, ":")
mySelectRange = Left(mySelectRange, IntInstr - 1)
do_insertPic picname, mySelectRange, rcell.Left, rcell.Top
End If
Next
Application.ScreenUpdating = True
End Sub
Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Integer)
Dim rcell As Range
Range(MyRange).Select
On Error GoTo ErrNoPhoto
ActiveSheet.Pictures.Insert(picname).Select
On Error GoTo 0
With Selection
.Left = myleft + 4
.Top = mytop + 4
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Height = 115#
.ShapeRange.Rotation = 0#
End With
Exit Sub
ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
End Sub
I have modified my code to use the formatting for Shapes.AddPicture. Here is the new code:
Sub InsertPictures()
Dim MyRange As String
Dim picname As String
Dim mySelectRange As String
Dim rcell As Range
Dim IntInstr As Integer
Dim Mypath As String
Mypath = "S:\pp4\images\"
MyRange = "A2:A275"
Range(MyRange).Select
For Each rcell In Selection.Cells
If Len(rcell.Value) > 0 Then
picname = Mypath & rcell.Value
mySelectRange = Replace(MyRange, "B", "A")
IntInstr = InStr(mySelectRange, ":")
mySelectRange = Left(mySelectRange, IntInstr - 1)
do_insertPic picname, mySelectRange, rcell.Left, rcell.Top
End If
Next
Application.ScreenUpdating = True
End Sub
Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Integer)
Dim rcell As Range
Range(MyRange).Select
On Error GoTo ErrNoPhoto
ActiveSheet.Shapes.AddPicture(Filename:=picname, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=myleft + 4, Top:=mytop + 4, LockAspectRatio:=msoTrue, Height:=115#, Rotation:=0#).Select
On Error GoTo 0
Exit Sub
ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
End Sub
When I try to run the new macro Excel just puts up my "Unable to Find Photo" error message. Can you help me find what I did wrong? Thanks for any help!
You have 2 extra arguments in Shapes.AddPicture (LockAspectRatio, Rotation), and a missing one (Width).
See more details about Shapes.AddPicture, and your corrected code below:
Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Integer)
Dim sht As Worksheet: Set sht = ActiveSheet
Dim rcell As Range
Range(MyRange).Select
On Error GoTo ErrNoPhoto
With sht.Shapes
.AddPicture _
Filename:=picname, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=myleft + 4, _
Top:=mytop + 4, _
Width:=-1, _
Height:=115
End With
On Error GoTo 0
Exit Sub
ErrNoPhoto:
Debug.Print "Unable to Find Photo" 'Shows message box if picture not found
End Sub
PS: I recommend you to read about avoiding to use .Select in everything...
I'm trying to find and replace a list of words inside a PowerPoint slide with values from cells in an Excel file. I'm running the VBA in PowerPoint and it gives this error.
Run-time error '-2147024809 (80070057)': The specified value is out of range.
The code seems to stop at this line (the first one):
Set ShpTxt = shp.TextFrame.TextRange
I've gone through other posts that have similar purposes and errors and tried about 20 different combinations, from both the Internet and from my ideas but none works.
Sub MergePPT3()
Dim pp As Object
Dim pptemplate As Object
'Dim headerbox As TextRange
'Dim contextbox As TextRange
Dim x As Long
Dim y As Long
Dim sld As Slide
Dim shp As Shape
Dim ShpTxt As TextRange
Dim TmpTxt As TextRange
Dim FindList As Variant
Dim ReplaceList As Variant
Dim ExApp As Object
Dim ExInput As Object
Dim SuName As String
Dim WFWS As String
Dim WFYOY As String
Dim CGWS As String
Dim CGYOY As String
Dim RNKG As String
Dim MKTCAT As String
Set ExApp = GetObject(, "Excel.Application")
ExApp.Visible = True
Set ExInput = ExApp.Workbooks.Open(ActivePresentation.Path & "/Testing.xlsm")
y = 2
SuName = ExInput.Sheets("SuIDs").Range("B" & y).Value
WFWS = ExInput.Sheets("SuIDs").Range("C" & y).Value
WFYOY = ExInput.Sheets("SuIDs").Range("D" & y).Value
CGWS = ExInput.Sheets("SuIDs").Range("E" & y).Value
CGYOY = ExInput.Sheets("SuIDs").Range("F" & y).Value
RNKG = ExInput.Sheets("SuIDs").Range("G" & y).Value
MKTCAT = ExInput.Sheets("SuIDs").Range("H" & y).Value
FindList = Array("SUNAME", "WFWS", "WFYOY", "CGWS", "CGYOY", "RNKG", "MKTCAT")
ReplaceList = Array(SuName, WFWS, WFYOY, CGWS, CGYOY, RNKG, MKTCAT)
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
'Store shape text into a variable
Set ShpTxt = shp.TextFrame.TextRange
'Ensure There is Text To Search Through
If ShpTxt <> "" Then
For x = LBound(FindList) To UBound(FindList)
'Store text into a variable
Set ShpTxt = shp.TextFrame.TextRange
'Find First Instance of "Find" word (if exists)
Set TmpTxt = ShpTxt.Replace( _
FindWhat:=FindList(x), _
Replacewhat:=ReplaceList(x), _
WholeWords:=True)
'Find Any Additional instances of "Find" word (if exists)
Do While Not TmpTxt Is Nothing
Set ShpTxt = ShpTxt.Characters(TmpTxt.Start + TmpTxt.Length, ShpTxt.Length)
Set TmpTxt = ShpTxt.Replace( _
FindWhat:=FindList(x), _
Replacewhat:=ReplaceList(x), _
WholeWords:=True)
Loop
Next x
End If
Next shp
Next sld
End Sub
I used variable "y" as a possibility to loop this code for multiple rows of inputs within the Excel file.
Not all shapes have a TextFrame.
From the documentation:
Use the HasTextFrame property to determine whether a shape contains a text frame before you apply the TextFrame property.
So try:
If shp.HasTextFrame
Set ShpTxt = shp.TextFrame.TextRange
End If
I export e-mail details from an Outlook 2007 shared inbox folder into an Excel 2007 sheet (Sender, Subject, Date & time received).
I then use formulas in Excel 2007 to attempt to extract a reference from the subject. Then lookup the reference against some data exported from our computer system.
If the reference matches with a file reference then set criteria from a formula will populate an answer in column D (so that's Sender, Subject, Date & time received, Yes/No).
If the reference can't be found or the data from the file doesn't meet the criteria to merit a response column D will then show "Yes" (meaning it needs to be marked as read and moved to the folder "No Response" which is part of the same shared mailbox on the same level as the inbox) otherwise will show "No" (in which case nothing needs to be done to that e-mail). The Yes/No Column formula criteria will be a continuous work in progress.
Exporting the e-mail details into an Excel sheet works and so do all of the formulas.
I've not managed to get Outlook to take the appropriate action from the details in the Excel sheet.
Sub ExportToExcel()
' Fully working, will export Sender, Subject & Date Received from e-mails into spreadsheet *** Except For Non-Mail Items ***
' If getting "spreadsheet user-defined type not defined" go to Visual Basic > Tools > References and tick 'Microsoft Excel 12.0 Object Library'
On Error GoTo ErrHandler
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
'Set path for spreadsheet
strSheet = "OE.xlsx"
strPath = "C:\Users\JM\Desktop\"
strSheet = strPath & strSheet
Debug.Print strSheet
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
intRowCounter = intRowCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
intColumnCounter = intColumnCounter
Set rng = wks.Cells(intRowCounter, intColumnCounter)
'rng.Value = msg.SenderEmailAddress
rng.Value = msg.SenderEmailAddress
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Subject
intColumnCounter = intColumnCounter
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.ReceivedTime
Next itm
MsgBox "Export Complete", vbOKOnly, "Information"
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
ErrHandler:
If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
Else
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
MsgBox "Export Completed", vbOKOnly
End Sub
This is what the spreadsheet would look like, I can't show the original because of data protection.
Most of the code has been put together from a few different websites.
The predominant source of the code was this site
http://www.vbaexpress.com/forum/showthread.php?52247-Macro-to-send-out-email-based-on-criteria-via-outlook/page3&s=11b5bf88fb5e89d06f7c8b43f6f92d2e
I want the following code to:
Mark the "Yes" e-mails as read and move them into the shared "No Response" folder in Outlook (in the same shared mailbox as the inbox the e-mail details were exported from).
This is where I am so far. The code will recognise an e-mail, mark it as unread, flag it as complete but it won't move the items into the folder or process the whole folder.
Option Explicit
Const strWorkbook As String = "C:\Users\jmurrey\Desktop\OE.xlsm" 'The path of the workbook
Const strSheet As String = "Sheet1" 'The name of the worksheet
Sub ProcessFolder()
Dim olItem As Object
Dim olFolder As Folder
Set olFolder = Session.PickFolder 'select the folder
For Each olItem In olFolder.Items 'loop through the items
If TypeName(olItem) = "MailItem" Then
MoveToFolder olItem 'run the macro
End If
Exit For
Next olItem
Set olItem = Nothing
lbl_Exit:
Exit Sub
End Sub
Sub MailFilter()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
MoveToFolder olMsg
lbl_Exit:
Exit Sub
End Sub
Sub MoveToFolder(olMail As Outlook.MailItem)
Dim olReply As Outlook.MailItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim Arr() As Variant
Dim iCols As Long
Dim iRows As Long
Dim strName As String
'load the worksheet into an array
Arr = xlFillArray(strWorkbook, strSheet)
With olMail
For iRows = 0 To UBound(Arr, 2) 'Check each row of the array
'If column 2 (starting at column 0) contains the e-mail address of the message
If .SenderEmailAddress = Arr(0, iRows) Then
'If the subject value is in the message subject
If InStr(1, .Subject, Arr(1, iRows)) > 0 Then
If InStr(1, .ReceivedTime, Arr(2, iRows)) > 0 Then
'If the received time is in the message subject
If InStr(1, "Yes", Arr(3, iRows)) > 0 Then
'If The string above matches then mark the email as unread and move to 'No Response' folder
'MsgBox "Match Found", vbOKOnly, "Match"
.FlagStatus = olFlagComplete
.UnRead = False
.Save
.Move Application.Session.Folders("No Response")
Exit For
End If
End If
End If
End If
Next iRows
End With
lbl_Exit:
Set olReply = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub
Private Function xlFillArray(strWorkbook As String, _
strWorksheetName As String) As Variant
Dim RS As Object
Dim CN As Object
Dim iRows As Long
strWorksheetName = strWorksheetName & "$]"
Set CN = CreateObject("ADODB.Connection")
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1
With RS
.MoveLast
iRows = .RecordCount
.MoveFirst
End With
xlFillArray = RS.GetRows(iRows)
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function
How do I move e-mails to the folder "No Response" which is in the same shared mailbox as the inbox the data has been exported from and also run through all of the e-mails in the Excel sheet rather than just one.
I have many issues with your code. With some issues, I am sure your code is faulty. With other issues I am not so sure. I will work down your code discussing my issues which I hope will help you address your problem.
Don’t use On Error GoTo ErrHandler during development or after release if you can avoid it. Your code will report the non-existence of the workbook but in the event of any other error it will just stop without giving no indication that it has failed to complete its task or the reason.
Try this for the workbook problem and add code for any other problems as they are discovered:
Set wkb = Nothing
On Error Resume Next
Set wkb = appExcel.Workbooks.Open(strSheet)
On Error GoTo 0
If wkb Is Nothing Then
Call MsgBox("I cannot open the workbook", vbOKOnly)
Exit Sub
End If
Dim intRowCounter As Integer. We were told to stop using data type Integer with VBA because it declares a 16-bit variable and such variables required special – slow - processing on 32 and 64-bit computers. When I got around to testing this claim, I was unable to detect any difference in processing speed. My reason for not using Integer for a row number is that its maximum value is 32767. I assume you will not have that many emails per folder but I will still suggest you get into the habit of declaring row numbers as Long.
You do not initialise intRowCounter. The default value is 0 and you add 1 before first use so it starts as 1.
strSheet = "OE.xlsx". Not very important but I hate anything that might cause confusion in the future. "OE.xlsx" is the name of a workbook and not the name of a worksheet. The term “spreadsheet” dates back to when there was only one sheet per file and I consider it obsolete.
You use PickFolder to select the folder which is fine if you want to be able run this macro against multiple folders. I was concerned you were using PickFolder because you did not know how else to get a folder reference particularly as you are using Explorer in MailFilter().
Alternatively, since you are playing with Explorer, perhaps this technique will appeal. The user selects the target folder and then starts your macro with this code at the beginning:
Dim Exp As Outlook.Explorer
Dim Fldr As Folder
Set Exp = Outlook.Application.ActiveExplorer
If Exp.Selection.Count = 0 Then
Call MsgBox("No emails selected", vbOKOnly)
Exit Sub
Else
Set Fldr = Exp.Selection(1).Parent
End If
Exp.Selection(1) is the first or only selected email.
Exp.Selection(1).Parent is the folder containing the selected email.
There is no need to activate the worksheet.
I would never identify columns by number unless the nature of the task required it. I would replace your code by:
Const ColEmSenderEmailAddress As Long = 1
Const ColEmSubject As Long = 2
Const ColEmReceivedTime As Long = 3
wks.Cells(intRowCounter, ColEmSenderEmailAddress).Value = msg.SenderEmailAddress
wks.Cells(intRowCounter, ColEmSubject).Value = msg.Subject
wks.Cells(intRowCounter, ColEmReceivedTime).Value = msg.ReceivedTime
I think this is easier to read and, more importantly, if any of the columns move, you only need to update the constants.
In your first macro you use For Each itm In fld.Items to access the mail items. In the second you use Explorer to access the first or only selected email. You must be consistent.
I rarely use For Each itm In fld.Items and have never experimented with the sequence in which items are presented to the macro. In the second macro, you will be removed items from the folder by moving them elsewhere. Again I have never experimented so do not know how this might affect the items returned by For Each itm In fld.Items. I doubt there will be an effect but you will need to check if you want to use For Each itm In fld.Items in both macros.
I would use something like this for the first macro:
Dim InxMi As Long
Dim itm As MailItem
For InxMi = 1 To Fldr.Items.Count
Set itm = Fldr.Items(InxMi)
Output macro to worksheet
Next
Since you start at row 1 in the worksheet, this would mean the item number InxMi and the row number intRowCounter would be the same make matching rows and mail items in the second macro easier. If there is no change to the folder between creating the worksheet and running the second macro, there will be an exact match. If you allow additions and deletion between the two macros, it will be more complicated but rows and the mail items will be in the same sequence so not too complicated.
In the second macro, you need to start at the bottom row of the worksheet and read the folder up from the bottom:
For InxMi = Fldr.Items.Count To 1 Step -1
Set itm = Fldr.Items(InxMi)
If appropriate Move item
Next
Mail items within a folder are like rows within worksheets, if you delete one then all the one below move up. If you move up the worksheet and the folder, the row and mail items will continue to match because the moved mail items will below the current position.
You do not give enough detail for me to be more specific but I hope the above helps you progress.
Hey why not run it from your Excel file and keep it simple -
Basic Example
Option Explicit
Public Sub Example()
Dim App As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Item As Object
Dim iRow As Long
Dim i As Long
Dim RevdTime As String
Dim Subject As String
Dim Email As String
Set App = New Outlook.Application
Set olNs = App.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox) ' Inbox
Set Items = Inbox.Items
iRow = 1 ' Row Count
With Worksheets("Sheet1") ' Update with Correct Sheet Name
Do Until IsEmpty(.Cells(iRow, 4))
DoEvents
If Cells(iRow, 4).Value = "Yes" Then
RevdTime = .Cells(iRow, 3).Value ' Email ReceivedTime
Subject = .Cells(iRow, 2).Value ' Email Subject
Email = .Cells(iRow, 1).Value ' Email Sender Name
For i = Items.Count To 1 Step -1
Set Item = Items(i)
If Item.Class = olMail And _
Item.Subject = Subject And _
Item.ReceivedTime = RevdTime And _
Item.SenderEmailAddress = Email Then
Debug.Print Item.Subject ' Immediate Window
Debug.Print Item.ReceivedTime ' Immediate Window
Debug.Print Item.SenderEmailAddress ' Immediate Window
Item.UnRead = False
Item.Save
Item.Move olNs.GetDefaultFolder(olFolderInbox) _
.Folders("No Response")
End If
Next
End If
iRow = iRow + 1 ' Go to Next Row
Loop
End With
Set App = Nothing
Set olNs = Nothing
Set Inbox = Nothing
Set SubFolder = Nothing
Set Items = Nothing
Set Item = Nothing
End Sub
for Late Binding see
Option Explicit
Public Sub Example()
Dim App As Object ' Outlook.Application
Dim olNs As Object ' Outlook.Namespace
Dim Inbox As Object ' Outlook.MAPIFolder
Dim SubFolder As Object ' Outlook.MAPIFolder
Dim Items As Object ' Outlook.Items
Dim Item As Object
Dim iRow As Long
Dim i As Long
Dim RevdTime As String
Dim Subject As String
Dim Email As String
Set App = CreateObject("Outlook.Application")
Set olNs = App.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(6) ' olFolderInbox = 6
Set Items = Inbox.Items
iRow = 1 ' Row Count
With Worksheets("Sheet1") ' Update with Correct Sheet Name
Do Until IsEmpty(.Cells(iRow, 4))
DoEvents
If Cells(iRow, 4).Value = "Yes" Then
RevdTime = .Cells(iRow, 3).Value ' Email ReceivedTime
Subject = .Cells(iRow, 2).Value ' Email Subject
Email = .Cells(iRow, 1).Value ' Email Sender Name
For i = Items.Count To 1 Step -1
Set Item = Items(i)
' olMail - 43 = A MailItem object.
If Item.Class = 43 And _
Item.Subject = Subject And _
Item.ReceivedTime = RevdTime And _
Item.SenderEmailAddress = Email Then
Debug.Print Item.Subject ' Immediate Window
Debug.Print Item.ReceivedTime ' Immediate Window
Debug.Print Item.SenderEmailAddress ' Immediate Window
Item.UnRead = False
Item.Save
Item.Move olNs.GetDefaultFolder(6) _
.Folders("No Response")
End If
Next
End If
iRow = iRow + 1 ' Go to Next Row
Loop
End With
Set App = Nothing
Set olNs = Nothing
Set Inbox = Nothing
Set SubFolder = Nothing
Set Items = Nothing
Set Item = Nothing
End Sub
If you want to run it from Outlook let me know it shouldn't be hard-
I did not know where to start with fixing your code so I have started from scratch based on my best guesses regarding your requirement.
I created a file named OE.xlsx with a single worksheet named “Emails” since I avoid using the default worksheet names. I created a header line with values: “Sender”, “Subject”, “Received”, “Yes/No” and “Folder”. I have maintained your sequence although I have added “Folder”.
I have named the main macros as “Part1” and “Part2” so there is no confusion with the other macros. All the other macros are from my library. They are more complicated than you need but I did not want to spend time coding something simpler. I suggest you accept these routines do what the comments say and not worry about how.
You have not said if the source of the emails is always the same shared folder. I added the folder column to allow for multiple shared folders. It means macro “Part2” does not need to ask about the source folder since it gets this information from the workbook although it would need to be told about the destination folder.
You do not say how you create the formulae that sets the value in the “Yes/No” column. I would get macro “Part1” to create them and I have included an example which sets “Yes” or “No” depending on the length of the subject.
In macro “Part1”, I use “For Each FldrSrcNameArr … ” to get details of emails from two folders. If you have fixed source folders, you can use something similar. If your requirement is more complicated, you will need to provide more detail.
Macro “Part1” adds new emails below any existing rows. In macro “Part2”, I clear the rows for emails that are moved and then write the remaining rows back to the worksheet. I know your macros do not work like this but I wanted to show what is possible. You can easily delete the redundant code if you do not require it.
I believe you should find it easy to adjust the following code to your requirements. Come back questions if necessary.
Option Explicit
' Requires references to "Microsoft Excel nn.0 Object Library", "Microsoft Office
' nn.0 Object Library" and "Microsoft Scripting Runtime" Value of "nn" depends
' on version of Office being used.
' Technique for locating desktop from answer by Kyle:
' http://stackoverflow.com/a/17551579/973283
Const ColEmailSender As Long = 1
Const ColEmailSubject As Long = 2
Const ColEmailReceived As Long = 3
Const ColEmailYesNo As Long = 4
Const ColEmailFolderName As Long = 5
Const RowEmailDataFirst As Long = 2
Sub Part1()
Dim ColEmailLast As Long
Dim FldrSrc As Folder
Dim FldrSrcName As String
Dim FldrSrcNameArr As Variant
Dim ItemCrnt As MailItem
Dim ItemsSrc As Items
Dim Path As String
Dim RowEmailCrnt As Long
Dim WbkEmail As Excel.Workbook
Dim WshtEmail As Excel.Worksheet
Dim xlApp As Excel.Application
Path = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
Set xlApp = Application.CreateObject("Excel.Application")
xlApp.Visible = True ' This slows your macro but helps during debugging
With xlApp
Set WbkEmail = .Workbooks.Open(Path & "OE.xlsx")
End With
With WbkEmail
Set WshtEmail = .Worksheets("Emails")
End With
Call FindLastRowCol(WshtEmail, RowEmailCrnt, ColEmailLast)
' Output first new row under any existing rows.
RowEmailCrnt = RowEmailCrnt + 1
For Each FldrSrcNameArr In VBA.Array(VBA.Array("test folders", "Test emails 1"), _
VBA.Array("test folders", "Test emails 2"))
Set FldrSrc = GetFldrRef(FldrSrcNameArr)
FldrSrcName = Join(GetFldrNames(FldrSrc), "|")
Set ItemsSrc = FldrSrc.Items
' This shows how to sort the emails by a property should this be helpful.
ItemsSrc.Sort "[ReceivedTime]" ' Ascending sort. Add ", False" for descending
For Each ItemCrnt In ItemsSrc
With ItemCrnt
WshtEmail.Range(WshtEmail.Cells(RowEmailCrnt, 1), _
WshtEmail.Cells(RowEmailCrnt, 5)).Value = _
VBA.Array(.SenderEmailAddress, .Subject, .ReceivedTime, _
"=IF(MOD(LEN(" & ColCode(ColEmailSubject) & RowEmailCrnt & "),2)=0,""Yes"",""No"")", _
FldrSrcName)
End With
RowEmailCrnt = RowEmailCrnt + 1
Next
Set ItemCrnt = Nothing
Set ItemsSrc = Nothing
Set FldrSrc = Nothing
Next
WbkEmail.Close SaveChanges:=True
Set WshtEmail = Nothing
Set WbkEmail = Nothing
xlApp.Quit
Set xlApp = Nothing
End Sub
Sub Part2()
Dim ColEmailCrnt As Long
Dim ColEmailLast As Long
Dim FldrDest As Folder
Dim FldrSrc As Folder
Dim FldrSrcNameCrnt As String
Dim FldrSrcNamePrev As String
Dim InxIS As Long
Dim ItemsSrc As Items
Dim ItemsToMove As New Collection
Dim Path As String
Dim RngSortF As Range
Dim RngSortR As Range
Dim RngWsht As Range
Dim RowEmailCrnt As Long
Dim RowEmailLast As Long
Dim WbkEmail As Excel.Workbook
Dim WshtEmail As Excel.Worksheet
Dim WshtEmailValues As Variant
Dim xlApp As Excel.Application
Path = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
Set xlApp = Application.CreateObject("Excel.Application")
xlApp.Visible = True ' This slows your macro but helps during debugging
With xlApp
Set WbkEmail = .Workbooks.Open(Path & "OE.xlsx")
End With
With WbkEmail
Set WshtEmail = .Worksheets("Emails")
End With
Call FindLastRowCol(WshtEmail, RowEmailLast, ColEmailLast)
With WshtEmail
Set RngWsht = .Range(.Cells(1, 1), .Cells(RowEmailLast, ColEmailLast))
Set RngSortF = .Range(.Cells(2, ColEmailFolderName), .Cells(RowEmailLast, ColEmailFolderName))
Set RngSortR = .Range(.Cells(2, ColEmailReceived), .Cells(RowEmailLast, ColEmailReceived))
' Ensure rows are sequecnced by Folder name then Received
' For each folder, the items are sorted by ReceivedTime. THis means the two lists
' are in the same sequence.
With .Sort
.SortFields.Clear
.SortFields.Add Key:=RngSortF, SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=RngSortR, SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SetRange RngWsht
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
WshtEmailValues = RngWsht.Value
End With
FldrSrcNamePrev = ""
Set FldrDest = GetFldrRef("test folders", "No response")
For RowEmailCrnt = RowEmailDataFirst To RowEmailLast
If WshtEmailValues(RowEmailCrnt, ColEmailYesNo) = "Yes" Then
' This row identifies an email that is to be moved
FldrSrcNameCrnt = WshtEmailValues(RowEmailCrnt, ColEmailFolderName)
If FldrSrcNamePrev <> FldrSrcNameCrnt Then
' New source folder
Set FldrSrc = Nothing
Set FldrSrc = GetFldrRef(Split(FldrSrcNameCrnt, "|"))
FldrSrcNamePrev = FldrSrcNameCrnt
Set ItemsSrc = FldrSrc.Items
ItemsSrc.Sort "[ReceivedTime]"
InxIS = 1
End If
' Scan down mail items within sorted folder until reach or are past current email
Do While InxIS <= ItemsSrc.Count
If ItemsSrc(InxIS).ReceivedTime >= WshtEmailValues(RowEmailCrnt, ColEmailReceived) Then
Exit Do
End If
InxIS = InxIS + 1
Loop
If InxIS <= ItemsSrc.Count Then
If ItemsSrc(InxIS).ReceivedTime = WshtEmailValues(RowEmailCrnt, ColEmailReceived) And _
ItemsSrc(InxIS).SenderEmailAddress = WshtEmailValues(RowEmailCrnt, ColEmailSender) And _
ItemsSrc(InxIS).Subject = WshtEmailValues(RowEmailCrnt, ColEmailSubject) Then
' Have found email to be moved
' ItemsSrc is what VBA calls a Collection but most languages call a List.
' Moving a mail item to another folder removes an item from the Collection and
' upsets the index. Better to save a reference to the mail item and move it later.
ItemsToMove.Add ItemsSrc(InxIS)
' Clear row in WshtEmailValues to indicate email moved
For ColEmailCrnt = 1 To ColEmailLast
WshtEmailValues(RowEmailCrnt, ColEmailCrnt) = ""
Next
InxIS = InxIS + 1
' Else there is no mail item matching email row
End If
' Else no more emails in folder
End If
' Else email row marled "No"
End If
Next
' Move mail items marked "Yes"
Do While ItemsToMove.Count > 0
ItemsToMove(1).Move FldrDest
ItemsToMove.Remove 1
Loop
' Upload worksheet values with rows for moved files cleared
RngWsht.Value = WshtEmailValues
' Sort blank lines to bottom
With WshtEmail
With .Sort
.Apply
End With
End With
WbkEmail.Close SaveChanges:=True
Set WshtEmail = Nothing
Set WbkEmail = Nothing
xlApp.Quit
Set xlApp = Nothing
'Set ItemCrnt = Nothing
'Set ItemsSrc = Nothing
'Set FldrSrc = Nothing
End Sub
' =================== Standard Outlook VBA routines ===================
Function GetFldrNames(ByRef Fldr As Folder) As String()
' * Fldr is a folder. It could be a store, the child of a store,
' the grandchild of a store or more deeply nested.
' * Return the name of that folder as a string array in the sequence:
' (0)=StoreName (1)=Level1FolderName (2)=Level2FolderName ...
' 12Oct16 Coded
' 20Oct16 Renamed from GetFldrNameStr and amended to return a string array
' rather than a string
Dim FldrCrnt As Folder
Dim FldrNameCrnt As String
Dim FldrNames() As String
Dim FldrNamesRev() As String
Dim FldrPrnt As Folder
Dim InxFN As Long
Dim InxFnR As Long
Set FldrCrnt = Fldr
FldrNameCrnt = FldrCrnt.Name
ReDim FldrNamesRev(0 To 0)
FldrNamesRev(0) = Fldr.Name
' Loop getting parents until FldrCrnt has no parent.
' Add names of Fldr and all its parents to FldrName as they are found
Do While True
Set FldrPrnt = Nothing
On Error Resume Next
Set FldrPrnt = Nothing ' Ensure value is Nothing if following statement fails
Set FldrPrnt = FldrCrnt.Parent
On Error GoTo 0
If FldrPrnt Is Nothing Then
' FldrCrnt has no parent
Exit Do
End If
ReDim Preserve FldrNamesRev(0 To UBound(FldrNamesRev) + 1)
FldrNamesRev(UBound(FldrNamesRev)) = FldrPrnt.Name
Set FldrCrnt = FldrPrnt
Loop
' Copy names to FldrNames in reverse sequence so they end up in the correct sequence
ReDim FldrNames(0 To UBound(FldrNamesRev))
InxFN = 0
For InxFnR = UBound(FldrNamesRev) To 0 Step -1
FldrNames(InxFN) = FldrNamesRev(InxFnR)
InxFN = InxFN + 1
Next
GetFldrNames = FldrNames
End Function
Function GetFldrRef(ParamArray FolderNames() As Variant) As Folder
' FolderNames can be used as a conventional ParamArray: a list of values. Those
' Values must all be strings.
' Alternatively, its parameter can be a preloaded one-dimensional array of type
' Variant or String. If of type Variant, the values must all be strings.
' The first, compulsory, entry in FolderNames is the name of a Store.
' Each subsequent, optional, entry in FolderNames is the name of a folder
' within the folder identified by the previous names. Example calls:
' 1) Set Fldr = GetFolderRef("outlook data file")
' 2) Set Fldr = GetFolderRef("outlook data file", "Inbox", "Processed")
' 3) MyArray = Array("outlook data file", "Inbox", "Processed")
' Set Fldr = GetFolderRef(MyArray)
' Return a reference to the folder identified by the names or Nothing if it
' does not exist
Dim FolderNamesDenested() As Variant
Dim ErrNum As Long
Dim FldrChld As Folder
Dim FldrCrnt As Folder
Dim InxP As Long
Call DeNestParamArray(FolderNamesDenested, FolderNames)
If LBound(FolderNamesDenested) > UBound(FolderNamesDenested) Then
' No names specified
Set GetFolderRef = Nothing
Exit Function
End If
For InxP = 0 To UBound(FolderNamesDenested)
If VarType(FolderNamesDenested(InxP)) <> vbString Then
' Value is not a string
Debug.Assert False ' Fatal error
Set GetFolderRef = Nothing
Exit Function
End If
Next
Set FldrCrnt = Nothing
On Error Resume Next
Set FldrCrnt = Session.Folders(FolderNamesDenested(0))
On Error GoTo 0
If FldrCrnt Is Nothing Then
' Store name not recognised
Debug.Print FolderNamesDenested(0) & " is not recognised as a store"
Debug.Assert False ' Fatal error
Set GetFldrRef = Nothing
Exit Function
End If
For InxP = 1 To UBound(FolderNamesDenested)
Set FldrChld = Nothing
On Error Resume Next
Set FldrChld = FldrCrnt.Folders(FolderNamesDenested(InxP))
On Error GoTo 0
If FldrChld Is Nothing Then
' Folder name not recognised
Debug.Print FolderNamesDenested(InxP) & " is not recognised as a folder within " & _
Join(GetFldrNames(FldrCrnt), "->")
Debug.Assert False ' Fatal error
Set GetFldrRef = Nothing
Exit Function
End If
Set FldrCrnt = FldrChld
Set FldrChld = Nothing
Next
Set GetFldrRef = FldrCrnt
End Function
' =================== Standard VBA routines ===================
Sub DeNestParamArray(Denested() As Variant, ParamArray Original() As Variant)
' Each time a ParamArray is passed to a sub-routine, it is nested in a one
' element Variant array. This routine finds the bottom level of the nesting and
' sets RetnValue to the values in the original parameter array so that other routines
' need not be concerned with this complication.
' Nov10 Coded
' 6Aug16 Minor correction to documentation
' 6Aug16 The previous version did not correctly handle an empty ParamArray.
' 15Oct16 replaced call of NumDim by call of NumberOfDimensions
' Tested that routine could denest a ParamArray that started as a reloaded
' array rather than a list of values in a call.
Dim Bounds As Collection
Dim Inx1 As Long
Dim Inx2 As Long
Dim DenestedCrnt() As Variant
Dim DenestedTemp() As Variant
DenestedCrnt = Original
' Find bottom level of nesting
Do While True
If VarType(DenestedCrnt) < vbArray Then
' Have found a non-array element so must have reached the bottom level
Debug.Assert False ' Should have exited loop at previous level
Exit Do
End If
Call NumberOfDimensions(Bounds, DenestedCrnt)
' There is one entry in Bounds per dimension in NestedCrnt
' Each entry is an array: Bounds(N)(0) = Lower bound of dimension N
' and Bounds(N)(1) = Upper bound of dimenssion N
If Bounds.Count = 1 Then
If Bounds(1)(0) > Bounds(1)(1) Then
' The original ParamArray was empty
Denested = DenestedCrnt
Exit Sub
ElseIf Bounds(1)(0) = Bounds(1)(1) Then
' This is a one element array
If VarType(DenestedCrnt(Bounds(1)(0))) < vbArray Then
' But it does not contain an array so the user only specified
' one value (a literal or a non-array variable)
' This is a valid exit from this loop
'Debug.Assert False
Exit Do
End If
' The following sometimes crashed Outlook
'DenestedCrnt = DenestedCrnt(Bounds(1)(0))
If VarType(DenestedCrnt(Bounds(1)(0))) = vbArray + vbString Then
' DenestedCrnt(Bounds(1)(0))) is an array of strings.
' This is the array sought but it must be converted to an array
' of variants with lower bound = 0 before it can be returned.
ReDim Denested(0 To UBound(DenestedCrnt(Bounds(1)(0))) - LBound(DenestedCrnt(Bounds(1)(0))))
Inx2 = LBound(DenestedCrnt)
For Inx1 = 0 To UBound(Denested)
Denested(Inx1) = DenestedCrnt(Bounds(1)(0))(Inx2)
Inx2 = Inx2 + 1
Next
Exit Sub
End If
DenestedTemp = DenestedCrnt(Bounds(1)(0))
DenestedCrnt = DenestedTemp
Else
' This is a one-dimensional, non-nested array
' This is the usual exit from this loop
Exit Do
End If
Else
' This is an array but not a one-dimensional array
' There is no code for this situation
Debug.Assert False
Exit Do
End If
Loop
' Have found bottom level array. Save contents in Return array.
If LBound(DenestedCrnt) <> 0 Then
' A ParamArray should have a lower bound of 0. Assume the ParamArray
' was loaded with a 1D array that did not have a lower bound of 0.
' Build Denested so it has standard lbound
ReDim Denested(0 To UBound(DenestedCrnt) - LBound(DenestedCrnt))
Inx2 = LBound(DenestedCrnt)
For Inx1 = 0 To UBound(Denested)
Denested(Inx1) = DenestedCrnt(Inx2)
Inx2 = Inx2 + 1
Next
Else
Denested = DenestedCrnt
End If
End Sub
Function NumberOfDimensions(ByRef Bounds As Collection, _
ParamArray Params() As Variant) As Long
' Example calls of this routine are:
' NumDim = NumberOfDimensions(Bounds, MyArray)
' or NumDim = NumberOfDimensions(Bounds, Worksheets("Sheet1").Range("D4:E20"))
' * Returns the number of dimensions of Params(LBound(Params)). Param is a ParamArray.
' MyArray, in the example call, is held as the first element of array Params. That is
' it is held as Params(LBound(Params)) or Params(LBdP) where LBdP = LBound(Params).
' * If the array to test is a regular array, then, in exit, for each dimension, the lower
' and upper bounds are recorded in Bounds. Entries in Bounds are zero-based arrays
' with two entries: lower bound and upper bound.
' * If the array is a worksheet range, the lower bound values in Bounds are 1 and the
' upper bound values are the number of rows (first entry in Bounds) or columns (second
' entry in Bounds)
' * The collection Bounds is of most value to routines that can be pased an array as
' a parameter but does not know if that array is a regular array or a range. The values
' returned in Bounds means that whether the test array is a regular array or a range,
' its elements can be accessed so:
' For InxDim1 = Bounds(0)(0) to Bounds(0)(1)
' For InxDim2 = Bounds(1)(0) to Bounds(1)(1)
' : : :
' Next
' Next
' If there is an official way of determining the number of dimensions, I cannot find it.
' This routine tests for dimension 1, 2, 3 and so on until it get a failure.
' By trapping that failure it can determine the last test that did not fail.
' * Params() is a ParamArray because it allows the passing of arrays of any type.
' * The array to be tested in not Params but Params(LBound(Params)).
' * The routine does not check for more than one parameter. If the call was
' NumDim(Bounds, MyArray1, MyArray2), it would ignore MyArray2.
' Jun10 Coded
' Jul10 Documentation added
' 13Aug16 Return type changed from Integer
' 14Aug16 Upgraded to handle ranges. VarType reports a worksheet range as an
' array but LBound and UBound do not recognise a range as an array.
' Added Bounds to report bounds of both regular arrays and ranges.
' 14Aug16 Renamed from NumDim.
' 14Aug16 Switched between different approaches as built up understanding of
' bounds of ranges as documented elsewhere in macro.
' 15Aug16 Switched back to use of TestArray.
Dim InxDim As Long
Dim Lbd As Long
Dim LBdC As Long
Dim LBdP As Long
Dim LBdR As Long
Dim NumDim As Long
Dim TestArray As Variant
'Dim TestResult As Long
Dim UBdC As Long
Dim UBdR As Long
Set Bounds = New Collection
If VarType(Params(LBound(Params))) < vbArray Then
' Variable to test is not an array
NumberOfDimensions = 0
Exit Function
End If
On Error Resume Next
LBdP = LBound(Params)
TestArray = Params(LBdP)
NumDim = 1
Do While True
Lbd = LBound(TestArray, NumDim)
'Lbd = LBound(Params(LBdP), NumDim)
If Err.Number <> 0 Then
If NumDim > 1 Then
' Only known reason for failing is because array
' does not have NumDim dimensions
NumberOfDimensions = NumDim - 1
On Error GoTo 0
For InxDim = 1 To NumberOfDimensions
Bounds.Add VBA.Array(LBound(TestArray, InxDim), UBound(TestArray, InxDim))
'Bounds.Add VBA.Array(LBound(Params(LBdP), InxDim), _
UBound(Params(LBdP), InxDim))
Next
Exit Function
Else
Err.Clear
Bounds.Add VBA.Array(TestArray.Row, TestArray.Rows.Count - TestArray.Row + 1)
Bounds.Add VBA.Array(TestArray.Column, TestArray.Columns.Count - TestArray.Column + 1)
If Err.Number <> 0 Then
NumberOfDimensions = 0
Exit Function
End If
On Error GoTo 0
NumberOfDimensions = 2
Exit Function
End If
End If
NumDim = NumDim + 1
Loop
End Function
' =================== Standard Excel routines ===================
Function ColCode(ByVal ColNum As Long) As String
' Convert column number to column code
' For example: 1 -> A, 2 -> B, 26 -> Z and 27 -> AA
Dim PartNum As Long
' 3Feb12 Adapted to handle three character codes.
' 28Oct16 Renamed ColCode to match ColNum.
If ColNum = 0 Then
Debug.Assert False
ColCode = "0"
Else
ColCode = ""
Do While ColNum > 0
PartNum = (ColNum - 1) Mod 26
ColCode = Chr(65 + PartNum) & ColCode
ColNum = (ColNum - PartNum - 1) \ 26
Loop
End If
End Function
Sub FindLastRowCol(ByRef Wsht As Worksheet, ByRef RowLast As Long, _
ByRef ColLast As Long)
' Sets RowLast and ColLast to the last row and column with a value
' in worksheet Wsht
' The motivation for coding this routine was the discovery that Find by
' previous row found a cell formatted as Merge and Center but Find by
' previous column did not.
' I had known the Find would missed merged cells but this was new to me.
' Dec16 Coded
' 31Dec16 Corrected handling of UsedRange
' 15Feb17 SpecialCells was giving a higher row number than Find for
' no reason I could determine. Added code to check for a
' value on rows and columns above those returned by Find
Dim ColCrnt As Long
Dim ColLastFind As Long
Dim ColLastOther As Long
Dim ColLastTemp As Long
Dim ColLeft As Long
Dim ColRight As Long
Dim Rng As Range
Dim RowIncludesMerged As Boolean
Dim RowBot As Long
Dim RowCrnt As Long
Dim RowLastFind As Long
Dim RowLastOther As Long
Dim RowLastTemp As Long
Dim RowTop As Long
With Wsht
Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
If Rng Is Nothing Then
RowLastFind = 0
ColLastFind = 0
Else
RowLastFind = Rng.Row
ColLastFind = Rng.Column
End If
Set Rng = .Cells.Find("*", .Range("A1"), xlValues, , xlByColumns, xlPrevious)
If not Rng Is Nothing Then
If RowLastFind < Rng.Row Then
RowLastFind = Rng.Row
End If
If ColLastFind < Rng.Column Then
ColLastFind = Rng.Column
End If
End If
Set Rng = .Range("A1").SpecialCells(xlCellTypeLastCell)
If Rng Is Nothing Then
RowLastOther = 0
ColLastOther = 0
Else
RowLastOther = Rng.Row
ColLastOther = Rng.Column
End If
Set Rng = .UsedRange
If not Rng Is Nothing Then
If RowLastOther < Rng.Row + Rng.Rows.Count - 1 Then
RowLastOther = Rng.Row + Rng.Rows.Count - 1
End If
If ColLastOther < Rng.Column + Rng.Columns.Count - 1 Then
ColLastOther = Rng.Column + Rng.Columns.Count - 1
End If
End If
If RowLastFind < RowLastOther Then
' Higher row found by SpecialCells or UserRange
Do While RowLastOther > RowLastFind
ColLastTemp = .Cells(RowLastOther, .Columns.Count).End(xlToLeft).Column
If ColLastTemp > 1 Or .Cells(RowLastOther, 1).Value <> "" Then
' Row after RowLastFind has value
RowLastFind = RowLastOther
Exit Do
End If
RowLastOther = RowLastOther - 1
Loop
ElseIf RowLastFind > RowLastOther Then
Debug.Assert False
' Is this possible
End If
RowLast = RowLastFind
If ColLastFind < ColLastOther Then
' Higher column found by SpecialCells or UserRange
Do While ColLastOther > ColLastFind
RowLastTemp = .Cells(.Rows.Count, ColLastOther).End(xlUp).Row
If RowLastTemp > 1 Or .Cells(1, ColLastOther).Value <> "" Then
Debug.Assert False
' Column after ColLastFind has value
ColLastFind = ColLastOther
Exit Do
End If
ColLastOther = ColLastOther - 1
Loop
ElseIf ColLastFind > ColLastOther Then
Debug.Assert False
' Is this possible
End If
ColLast = ColLastFind
End With
End Sub