why does my VBA code that works in module not work as expected when assigned to a worksheet and a button - vba

I have a workbook that is essentially an automated test, marking and feedback tool for end of topic tests for students. On the '701Test' sheetThey input their teaching group via a drop down list and the select their from subsequent list. They answer the multiple choice questions and press a button when finished. The button takes them to a 'results' page which gives their marks for each question, give feedback for incorrect answers and gives a total score. They then hit the finish button which generates a PDF copy of the mark sheet in their my documents folder and then emails a copy to themselves and the Schools email account. At this point I also wanted to post the final score to the students record on a central registry using a loop through the student list to find the name and offset to post the Score value from the 'Results' page and finally return to the test page. This last bit I wrote the code for in a module and it executes perfectly, but when added to the main code and run from the button the loop part fails to execute but the return to the test page does work, but no error is recorded for the loop failure.
Here is the 'Results' page code in full the 'With Central reg' bit at the bottom is the problem, any help is greatly appreciated.
Private Sub CommandButton1_Click()
Dim IsCreated As Boolean
Dim PdfFile As String, Title As String
Dim OutlApp As Object
Dim cell As Range
Dim Students As Range
Title = Range("D1").Value
sname = Range("B2").Value
PdfFile = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\" & sname & Title & ".pdf"
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
With OutlApp.CreateItem(0)
.Subject = Title
.to = Range("B2").Value ' <-- Put email of the recipient here"
.CC = "" ' <-- Put email of 'copy to' recipient here
.Body = "Hi," & vbLf & vbLf _
& "Yr 7 701 EOT test attached in PDF format." & vbLf & vbLf _
& "Regards," & vbLf _
& "KDS ICT Dept" & vbLf & vbLf
.Attachments.Add PdfFile
Application.Visible = True
.Display
End With
If IsCreated Then OutlApp.Quit
Set OutlApp = Nothing
With CentralReg
For Each cell In Range("A2:A250")
If cell = Range("Results!B2").Value Then
cell.Offset(0, 4).Activate
ActiveCell.Value = Range("Results!B27").Value
End If
Next
End With
End Sub

I believe you are trying to refer to CentralReg which is a worksheet, which means you should qualify it as such.
Also, you should not dim variables that are similar to defined objects/properties in VBE. Try MyCell instead of cell (good practice, not required).
I am assuming you want to see if the value on sheet CentralReg in Column A is equal to sheet Result B2. If this condition is met, your MyCell will take on the value equal sheet Result B27
Dim MyCell As Range
Dim Result, NewValue as Variant
Result = ThisWorkbook.Sheets("Result").Range("B2")
NewValue = ThisWorkbook.Sheets("Result").Range("B27")
With ThisWorkbook.Sheets("CentralReg")
For Each MyCell In .Range("A2:A250")
If MyCell = Result Then MyCell.Offset(, 4) = NewValue
Next MyCell
End With

That with statement is useless as nothing actually uses it within the construct.
Delete with CentralReg and End with and it will work.
alternatively if CentralReg IS something like a sheet then you need to precede your code with a . so this: Range("A2:A250") becomes this: .Range("A2:A250") and so on, the . tells the code that it is related to whatever your with construct surrounds

Related

Email loop causing Notes to crash (Embed object = issue)

I have the following code which is always causing IBM(LOTUS) Notes to crash at the .EmbedObject line
Call body.EmbedObject(1454, "", Attachment)
This is the part of the main code. At this point there are 2 dictionaries which are converted to arrays and then into e-mail strings. The call to the EMAIL sub-routine is below.
Anyone have any idea what could be causing this or know a fix?? All variables are declared at the public level in the main module with string type
This works fine with a simple loop macro that I used to integrate into my macro (basic for loop calling the email routine every iteration, with declaring the document and body each time)
thank you
Private Sub SaveFilestoDesktop_andEmail()
'Saves file to desktop with date stamp and e-mails to the user
Dim WB As Workbook
Dim wks As String
Dim fname As String, i As Integer
Dim EmailArray_PC() As Variant, EmailArray_PM() As Variant
EmailArray_PM = dict.keys()
EmailArray_PC = dict_2.keys()
i = 1
Subj = "Items to Review"
'EmailBody = "The following items have been flagged as possible cost errors " & _
'"by process of identifying variances of +/- 30 % compared to the current average cost. " & _
'"Please see attachment and review for internal purposes." & vbLf & _
'vbLf & VBA.Format(Now, "m/d/yyyy hh:mm:ss AM/PM")
On Error GoTo errhandlr
For Each WB In Workbooks
'Set the first sheet name of each WB to the wks variable
wks = WB.ActiveSheet.Name
'If unsaved workbook (only part of the above sub procedures)
If Left(WB.Name, 4) = "Book" Then
fname = Application.DefaultFilePath & "\" & Replace(WB.Worksheets(1).Name, ".", "") & "- " & VBA.FormatDateTime(Date, vbLongDate) _
& " (" & Format(Time, "hhmmss AMPM") & ")"
With WB
' If Dir(fname) <> "" Then
Application.DisplayAlerts = False
'Save the file as an .xlsx to the default user path
.SaveAs Filename:=fname, FileFormat:=51
Application.DisplayAlerts = True
On Error Resume Next 'if tries to e-mail but it fails (such as for "blank")
'Setting up parameters for e-mailing
SendTo = Right(EmailArray_PM(i), Len(EmailArray_PM(i)) - WorksheetFunction.Find(",", EmailArray_PM(i)) - 1) & "_" & _
Left(EmailArray_PM(i), WorksheetFunction.Find(",", EmailArray_PM(i)) - 1) & "#quadra.ca"
SendCC = Right(EmailArray_PC(i), Len(EmailArray_PC(i)) - WorksheetFunction.Find(",", EmailArray_PC(i)) - 1) & _
"_" & Left(EmailArray_PC(i), WorksheetFunction.Find(",", EmailArray_PC(i)) - 1) & "#quadra.ca"
Attachment = WB.Name
'Call e-mail maco in Other module
Call Email_using_Notes_Call(SendTo, SendCC, Attachment)
'Increment i by 1
i = i + 1
On Error GoTo 0
'Close the Workbook, go to next WB
.Close
End With
'Clear the filename to save with for next WB
fname = Empty
End If
Next WB
Exit Sub
Erase EmailArray_PC: Erase EmailArray_PM
Set dict = Nothing: Set dict_2 = Nothing 'clear dict objs
errhandlr:
MsgBox err.Number & Space(2) & err.Description
err.Clear
'MsgBox err.Number & Space(2) & err.Description
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Call to EMAIL loop:
Sub Email_using_Notes_Call(ByVal SendTo As String, _
Optional ByVal SendCC As String, Optional ByVal Attachment As String)
On Error Resume Next
'Creates the Notes Document (e-mail)
Set doc = db.CreateDocument
With doc
.Subject = Subj
.SendTo = SendTo
.CopyTo = SendCC
.Importance = "1"
End With
'Creating the body of the Notes document
Set body = doc.CreateRichTextItem("Body")
'Formatting the body of the text
Call body.AppendText("The following items have been flagged as possible cost errors by process of identifying variances of +/- 30 %")
Call body.AddNewline(1) '--> This adds a line feed to the body
Call body.AppendText("compared to the current average cost. Please see attachment and review for internal purposes ")
Call body.EmbedObject(1454, "", Attachment) --> this is where it crashes 'EMBED_ATTACHMENT[1454 = embed attachment, 1453 = embed object]
Call body.AddNewline(2)
Call body.AppendText(Now())
Call doc.Send(False) 'False is the variable that indicates attach form or not (always false in our case)
'Clearing for next document
Set body = Nothing
Set doc = Nothing
On Error GoTo -1
End Sub
I think this issue is caused what you are trying to embed.
The document you are trying to Embed is the Excel workbook itself. You have the workbook open, so it cannot necessarily be read due to a lock.
Something that might help you definitely find out if that's the reason:
Try to add another file as the attachment that isn't open and see if it works, as a test.
Change the On Error Resume Next located in your e-mailing function to an error handler, like you have in the function above it.

excel-vba: Turn text from cells with particular format into an object suitable for outlook e-mail body, while maintaining the same format properties

My problem is the following:
I want to define a range, including cells in my spreadsheet that contain formatted text (bold font), and turn it into any object that I can later use as the body for an outlook e-mail.
One of the ways I have tried so far is via the RangetoHTML function by Ron de Bruin (http://www.rondebruin.nl/win/s1/outlook/bmail2.htm). However, the function brings the text cells into another excel workbook which finally yields a table in the outlook e-mail. I want to keep the very same format that I start with in my excel cells. That is, it must be lines of ordinary text and not a table-like body in the mail.
That's my current code:
Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Sheets("Preparation").Range("A90:A131")
With Selection
.Value = rng.Text
.Font.Bold = rng.Font.Bold
.Font.Color = rng.Font.Color
End With
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.HTMLBody = RangetoHTML(rng)
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Thanks in advance for your help
Ron de Bruin’s RangeToHtml shows how to use Excel’s PublishObjects to convert a worksheet range to Html that can be used as the body of an email. I am sure this has helped thousands of developers.
The difficulty that RdeB overcomes is that PublishObjects is designed to create and maintain webpages. His routine outputs to a file and then reads that file because that is the only way to get the Html string required for the email body.
The difficulty that RdeB cannot overcome is that PublishObjects create poor quality, proprietary CSS. By “poor quality”, I mean that there is a lot of unnecessary CSS and that row heights and column widths are defined in points to give sizes suitable for a PC. By “proprietary”, I mean it uses styles such as mso-ignore:padding and mso-number-format:General that only Microsoft browsers are guaranteed to understand. It appears the major browsers are able to cope but many people have found that some newer browsers cannot cope and display rubbish.
To demonstrate this and to test my code, I created a worksheet based on your image. Rows 16 to 18 are right-aligned because I have specified this. Rows 20 to 22 are right aligned because this is the Excel default for numeric, date and time values. Its appearance is:
You can use your real data.
Copy this code to your workbook:
Option Explicit
Sub Test1()
Dim PathCrnt As String
Dim PathFileCrnt As String
Dim RngStr As String
Dim WshtName As String
PathCrnt = ThisWorkbook.Path & "\" ' ## Output to the same folder as workbook holding the macro
PathFileCrnt = PathCrnt & "Test1.html" ' ## Change if you do not like my filename
WshtName = "Sheet1" ' ## Change to your worksheet
RngStr = "A1:A28" ' ## Change to your range
With ThisWorkbook
With .PublishObjects.Add(SourceType:=xlSourceRange, _
Filename:=PathFileCrnt, _
Sheet:=WshtName, _
Source:=RngStr, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
End With
End Sub
You will need to change some of the statements near the top marked with ##
Run this macro to output your range to the file.
On my laptop, Microsoft Edge, Microsoft Internet Explorer and Google Chrome all display the file and all look the same although IE and Chrome are slow to display. The column is down the centre of the window:
There are none of the background grey cells and wide, white border you showed. However, I have not tried to display it within Outlook.
Now look at the file with your favourite text editor. Notice how much CSS is repeated. Notice how many style start “mso-” indicating they are Microsoft extensions. Notice the heights and widths measured in “pt” (points). Some Html display engines can cope but some cannot.
I suspect that PublishObjects has not been maintained. It was available with Excel 2003 and perhaps earlier. Some of the old Microsoft CSS extensions now have standard CSS equivalents but PublishObjects has not been updated to use them.
I have my own RangeToHtml written entirely in VBA. It will handle all formatting except borders. My code is far too big to post on Stack Overflow so I have extracted the bits you need. You apparently need bold or not bold and left or right alignment. I do not know if you specify right alignment or if you have numeric fields which right align by default so I handle both.
My function ColToHtml(range) returns a complete Html file for the first column of a range. My code does not create a temporary workbook or a temporary file. It produces clean, crisp Html and Css. It produces a table because you cannot have right-alignment outside a table. However, with no borders, it is not obvious the output is a table. The only difference in appearance is that the table is left aligned. If you prefer a centred table, it would be an easy change.
This was my test routine:
Sub Test2()
Dim Rng As Range
With Worksheets("Sheet1")
Set Rng = .Range(.Cells(1, 1), .Cells(28, 1))
End With
Debug.Print ColumnToHtml(Rng)
End Sub
It outputs the Html string to the Immediate Window. I then copied it to a file. I could have used VBA to write to a file but this was easier. When I opened the file with Microsoft Edge, it looked the same. Have a look at this second file with your favourite text editor. Notice how much smaller it is. The PublishObjects version is 6,901 bytes while this second version is 1,681 bytes. Notice how only standard Css is used and that the minimum of Css is used. This allows the display engine to make its own decisions about how to display the file based on the type of output device.
My last test was:
Sub Test3()
' This will need a reference to Microsoft Outlook nn.0 Outlook library
' where nn is the number of the Outlook version you are using.
Dim Rng As Range
Dim OutApp As Outlook.Application
Dim MailItemNew As Outlook.MailItem
With Worksheets("Sheet1")
Set Rng = .Range(.Cells(1, 1), .Cells(28, 1))
End With
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set MailItemNew = OutApp.CreateItem(olMailItem)
With MailItemNew
.BodyFormat = olFormatHTML
.HTMLBody = ColumnToHtml(Rng)
.Display
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set MailItemNew = Nothing
Set OutApp = Nothing
End Sub
This outputs the range to Outlook. I have used your code as a template but have referenced the Outlook library so I can use Outlook objects and constants. I had to reduce the font size to get it all on the screen at one time giving:
Again this has the same appearance except that the first letter of each line has been capitalized. I do not know how to stop the Outlook email editor doing this.
Incidentally, I selected the entire email and got the same appearance as in the image you posted.
The code for ColumnToHtml is below. Note that CellToHtml is the routine that actually creates the Html for a cell. It only handles bold and right alignment but it should be obvious that it would be easy to add other cell-level formats.
Function ColumnToHtml(ByRef RngCol As Range) As String
' Returns the first or only column of rng as a borderless table
' so it appears as a formatted list of rows.
Dim RngCell As Range
Dim RowCrnt As Long
Dim Table As String
' Build an Html table of the cells within the first column of RngCol
' ==================================================================
Table = Space(4) & "<table border=""0"">" & vbLf
For RowCrnt = RngCol.Row To RngCol.Row + RngCol.Rows.Count - 1
Set RngCell = RngCol.Worksheet.Cells(RowCrnt, RngCol.Column)
Table = Table & Space(6) & "<tr>" & CellToHtml(RngCell) & "</tr>" & vbLf
Next
Table = Table & Space(4) & "</table>"
' Build an Html file envelope around the table
' ============================================
ColumnToHtml = "<!DOCTYPE html PUBLIC ""-//W3C//DTD XHTML 1.0 Frameset//EN""" & _
"""http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd"">" & vbLf & _
"<html xmlns=""http://www.w3.org/1999/xhtml"" xml:lang=""en"" lang=""en"">" & vbLf & _
" <head></head>" & vbLf & _
" <meta http-equiv=""Content-Type""content=""text/html; charset=utf-8""/>" & vbLf & _
" <style>" & vbLf & _
" td.bold {font-weight:bold;}" & vbLf & _
" td.hAlign-right {text-align:right;}" & vbLf & _
" </style>" & vbLf & _
" </head>" & vbLf & _
" <body>" & vbLf & Table & vbLf & _
" </body>" & vbLf & _
"</html>"
End Function
Function CellToHtml(ByRef RngCell As Range) As String
' Convert a single cell to Html.
' This code handles: value, bold or not-bold (default) and left )default) or
' right-alignment.
' Note RngCell.Value is the value perhaps "1234" or "42999".
' and RngCell.Text is the display text perhaps "1,234" or "21-Sep-17".
' This is particularly important with dates and time where the
' value is unlikely to be what is displayed.
' Dates are held as days since 1-Jan-1900 and times are held as
' seconds-since-midnight / seconds-in-a-day. It is the NumberFormat that
' determine what you see.
Dim BoldCell As Boolean
Dim RAlignedCell As Boolean
Dim Style As String
Dim StyleNeeded As Boolean
CellToHtml = "<td"
' Add interior formatting here if required
If RngCell.Value = "" Then
' Ignore font and alignment formatting of empty cell.
Else
' Test for formats
BoldCell = False
RAlignedCell = False
Style = ""
StyleNeeded = False
If RngCell.Font.Bold Then
BoldCell = True
StyleNeeded = True
End If
If RngCell.HorizontalAlignment = xlRight Or _
(RngCell.HorizontalAlignment = xlGeneral And _
(IsNumeric(RngCell.Value) Or IsDate(RngCell.Value))) Then
RAlignedCell = True
StyleNeeded = True
End If
If StyleNeeded Then
CellToHtml = CellToHtml & " class="""
If BoldCell Then
If Style <> "" Then
Style = Style & " "
End If
Style = Style & "bold"
End If
If RAlignedCell Then
If Style <> "" Then
Style = Style & " "
End If
Style = Style & "hAlign-right"
End If
CellToHtml = CellToHtml & Style & """"
End If
End If
CellToHtml = CellToHtml & ">" ' Terminate "<td"
If RngCell.Value = "" Then
' Blank rows are displayed narrow. Use Non-blank space so display at homral width
CellToHtml = CellToHtml & " "
Else
CellToHtml = CellToHtml & RngCell.Text
End If
CellToHtml = CellToHtml & "</td>"
End Function
One last comment. You have not selected anything so I do not see the purpose of this code:
With Selection
.Value = rng.Text
.Font.Bold = rng.Font.Bold
.Font.Color = rng.Font.Color
End With

Code for checking to see if a new message with a specific subject line has been already created Lotus

I'm not a programmer so I apologize in advance.
I have three different worksheets in a workbook. Each sheet has a specific macro so that after numbers are entered, shift supervisors can press a button with the assigned macro and metrics from that sheet will be copied and pasted to a different worksheet in a format with filter-able/pivot-able columns. It then saves and closes the data, goes back to the shift report worksheet, copies the pertinent cells, then opens lotus and formats a new message with a subject line stating the correct shift number and date and pastes the shift report data into the body of the e-mail.
Since there is a different button to press on 3 worksheets, and I can't count on supervisors to enter numbers in any specific order, I need to be able to tell if Lotus has already opened and created an e-mail with that specific subject line to see if it needs to be created or if it exists with some information already in the body. Does anyone know if this is possible?
Dim NSession As Object
Dim NDatabase As Object
Dim NUIWorkSpace As Object
Dim NDoc As Object
Dim NUIdoc As Object
Dim WordApp As Object
Dim WordDoc As Object
Dim msg As String
msg = "Leads Report " & Now() & vbNewLine & vbNewLine & _
"Finishing:" & vbNewLine & _
"**PASTE Leadsheet CELLS HERE**" & vbNewLine & vbNewLine
Sheets("Leadsheet").Select
Set newRange = Range("e4")
mystring = RangeToString(newRange)
Set NSession = CreateObject("Notes.NotesSession")
Set NUIWorkSpace = CreateObject("Notes.NotesUIWorkspace")
Set NDatabase = NSession.GetDatabase("", "")
If Not NDatabase.IsOpen Then
NDatabase.OPENMAIL
End If
'Create a new document
'******************************(if statement to see
'if a document with specific subject line has already been
'created....'subject = doc.GetItemValue("subject")(0)???????
'****************************************
Set NDoc = NDatabase.createdocument
With NDoc
.SendTo = "email#email.com" 'CHANGE THIS
.CopyTo = ""
.Subject = Format(Date, "mm-dd-yyyy") & " Lead Report Shift " & mystring
'Email body text, including marker text which will be replaced by the Excel cells
.Body = msg
.Save True, False
End With
'Edit the just-created document to copy and paste the Excel cells into it
Set NUIdoc = NUIWorkSpace.editdocument(True, NDoc)
'Find the marker text in the Body item
'Replace it with the Excel cell
With NUIdoc
'leadsheet
Workbooks("Master Shift Report Sheet.xlsm").Activate
Sheets("LeadSheet").Select
Range("B2:o62").Select
ActiveWindow.zoom = 86
Selection.copy
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Add
With WordApp.Selection
.PasteSpecial DataType:=4 & vbNewLine
.wholestory
.copy
End With
.gotofield ("Body")
.findstring "**PASTE Leadsheet CELLS HERE**"
.Paste
'Application.CutCopyMode = False
'.Send
'.Close
End With
Set NSession = Nothing
anything else looks wonky don't hesitate to point it out! I'm learning.

Referencing an email address from a different sheet

I am having some trouble referencing an email address from a different sheet so I can send an email when a certain name is selected and "open" is chosen from a drop down box it will automatically send an email to that person. I have so far:
Sub Macro1()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("M").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#xyz.com" And _
LCase(Cells(cell.Row, "N").Value) = "open" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Open Issue"
.Body = "Dear " & Cells(cell.Row, "J").Value _
& vbNewLine & _
"Issue raised: " & Cells(cell.Row, "C").Value _
& vbNewLine & _
"Regards"
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
This works if I input an email address in to column M manually but I am trying to have it so that when a name is selected from a drop down box in J it matches up the email to the name and sends it when "open" is selected from column N.
I have created a table with names and emails in another sheet which M uses VLookup to reference using =VLOOKUP(J3,Team!B5:E8,4,FALSE). I have tried adding HYPERLINK in front of VLOOKUP but it still doesn't create a link.
I also tried creating the email address from the names using split and concatenate but to no avail.
Your problem is that you use SpecialCells(xlCellTypeConstants). Once you made column M a formula your code will now ignore all the cells that have formulas in column M.
You can adjust the xlCellTypeConstants to xlCellTypeFormulas or just get rid of SpecialCells altogether to include both.

how to copy values from the same named ranges from one workbook to another

I have an extensive Workbook which exists in multiple versions that contains hundreds of named ranges.
I want to write a macro that transfers user input data entered to certain named ranges from one instance of the book to another.
The named ranges in the book follow a certain convention, for the purposes of this macro i want to copy the values (which are constants) of all named ranges starting with "in_*" and "resetRange_*"
the macro is supposed to:
open the source book (which has mostly the same named ranges defined as the current book)
iterate over all named ranges of the source book and find the ones like "in_*" or "resetRange_*"
copy the values at the named ranges from the source book to the current book (even if the names refer to areas)
my main questions are:
how do i copy correctly? the current implementation does not work
is there a better way to test whether a source name is still present in the current book?
the named ranges in question all are scoped to the workbook.
The issue that the macro runs error free but does not paste any values. the named ranges of the current book remain empty while the source book contains data
´
Public Sub TransferInputDataFromOtherTool()
Dim sourceBook As Workbook
Dim bookPath As Variant
'get source book
bookPath = Application.GetOpenFilename("(*.xlsm), *.xlsm", Title:="Select source tool:")
If VarType(bookPath) = vbString Then
Set sourceBook = Workbooks.Open(bookPath)
End If
On Error GoTo Cleanup
'#TODO transfer ranges _
resetRange_* _
in_*
'retrieving data
For Each n In sourceBook.Names
On Error Resume Next
rangeName = n.Name
boola = ThisWorkbook.Names(n.Name)
If boola Then
On Error GoTo 0
If rangeName Like "in_*" _
or rangeName like "resetRange_*" Then
'check for allow edit
On Error Resume Next
sourceBook.Activate
source_value = n.refersToRange.Value
ThisWorkbook.Activate
Range(rangeName).Value = source_value
'Debug.Print rangeName, source_value
'Debug.Print Err.Description, Err.source
On Error GoTo 0
End If
' deleting all in_-values
End If
Next n
'#TODO transfer tables
'ExcelHandling.EnableInteractivity
Cleanup:
On Error Resume Next
sourceBook.Close
On Error GoTo 0
End Sub
Here's a code sample to help. Please turn on Option Explicit and define all your VBA variables. See if this works for you:
EDIT: added range check to detect more than one cell in a given range, then to copy each cell
Option Explicit
Sub TransferInputDataFromOtherTool()
Dim srcWB As Workbook
Dim destWB As Workbook
Dim filename As String
Dim definedVariable As Name
Dim singleCell As Range
Dim singleCellLocation As String
'--- the destination book is the currently active workbook from the user's perspective
Set destWB = ThisWorkbook
'--- source book from which to copy the data from - user selected
filename = Application.GetOpenFilename("(*.xlsm), *.xlsm", Title:="Select source tool:")
If filename = "False" Then
'--- the user selected cancel
Exit Sub
ElseIf filename = destWB.Path & "\" & destWB.Name Then
MsgBox "You can't open the same file that's already active. Select another file.", vbCritical + vbOKOnly
Exit Sub
Else
Set srcWB = Workbooks.Open(filename)
End If
Debug.Print "values coming from " & filename
For Each definedVariable In srcWB.Names
If (definedVariable.Name Like "in_*") Or (definedVariable.Name Like "resetRange_*") Then
'--- if the source/destination range is only a single cell, then
' it's an easy one-to-one copy
Debug.Print definedVariable.Name & " refers to " & definedVariable.RefersTo;
If destWB.Names(definedVariable.Name).RefersToRange.Cells.Count = 0 Then
'--- do nothing
ElseIf destWB.Names(definedVariable.Name).RefersToRange.Cells.Count = 1 Then
Debug.Print " source value = '" & destWB.Names(definedVariable.Name).RefersToRange.Value & "'";
Debug.Print " overwritten with '" & srcWB.Names(definedVariable.Name).RefersToRange.Value & "'"
destWB.Names(definedVariable.Name).RefersToRange = srcWB.Names(definedVariable.Name).RefersToRange.Value
Else
'--- the source/target range has multiple cells, either contiguous
' or non-contiguous. so loop and copy...
Debug.Print vbTab & "multiple cells in range..."
For Each singleCell In destWB.Names(definedVariable.Name).RefersToRange
singleCellLocation = "'" & singleCell.Parent.Name & "'!" & singleCell.Address
Debug.Print vbTab & " source value = '" & singleCell.Value & "'";
Debug.Print "' overwritten with '" & srcWB.Sheets(singleCell.Parent.Name).Range(singleCell.Address).Value & "'"
singleCell.Value = srcWB.Sheets(singleCell.Parent.Name).Range(singleCell.Address).Value
Next singleCell
End If
End If
Next definedVariable
srcWB.Close SaveChanges:=False
Set srcWB = Nothing
Set destWB = Nothing
End Sub