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

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

Related

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

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

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.

Saving a worksheet into a new workboook but using values instead of the referencing formulas

So I am trying to create a workbook that uses multiple references from a worksheet of the initial data to auto fill cells in different worksheets to produce Forms (pre-formated worksheets). For one of the worksheets, I need to save it on a separate network drive as its own .xlsx workbook. So far, the code I have developed creates the new workbook, but the cells all still contain the original formulas that reference the original workbook. Is there a way, when saving into the new workbook, to convert the cells to values? Here is the sub I have in place. TIA
Private Sub SaveBidTab1_Click()
' Saves the BidTab in the Current Year's Bid Tabs Folder in
' Dave's Snapserver Construction Files
Dim BTFName As String 'this will be the name of the new file name saved in the Bid Tabs Folder
Dim BTFfolder As String 'This is the folder to save the form into
Dim BTFDate As String 'This is the date to choose which year's folder to use
Dim ProjectShortName As String 'This is the short name for the project for the file name
Dim NewBook As Workbook ' This is temp workbook that the new bid tab sheet will be saved as
If Worksheets("BidTab").Range("G12") = "" Then
ans = MsgBox("This form is not ready to be saved", vbOKOnly, "Bid Tabs")
Select Case ans
Case vbOK
Exit Sub
End Select
End If
'Requests user to enter in short name for project
Msg = "Enter Project Short Name"
ProjectShortName = InputBox(Msg, "Save As")
' TRIAL is added here until project is compelted.
BTFName = "TRIAL " & Worksheets("Initial Entry").Range("B5") & " " & ProjectShortName & _
" " & "Bid Tab Results" & " " & Worksheets("BidTab").Range("L5")
' Add in a cancle option to this msgbox
MsgBox BTFName
BTFDate = Year(Now())
BTFfolder = "M:\DotserverD\Daves Snapserver Files Construction Files\Bid Tabs\" & BTFDate _
& "\County"
Debug.Print BTFfolder
Set NewBook = Workbooks.Add
ThisWorkbook.Worksheets("BidTab").Copy Before:=NewBook.Sheets(1)
NewBook.SaveAs Filename:=BTFfolder & "\" & BTFName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
End Sub
ThisWorkbook.Worksheets("BidTab").Copy Before:=NewBook.Sheets(1)
Put this after the above statement:
With NewBook.Sheets(1).UsedRange
.Value = .Value
End With
This will remove the links and keep only the values in the new worksheet.
I have this in a similar book. You can probably simplify it.
Dim shShape As Shape
For i = 1 To UBound(sheetNames)
mSaveWorkbook.Sheets(i).Name = sheetNames(i)
If mSaveWorkbook.Sheets(i).Shapes.Count > 0 Then
For Each shShape In mSaveWorkbook.Sheets(i).Shapes
If shShape.Type = msoFormControl Then
shShape.Delete
End If
Next shShape
End If
Next i
End If

Outlook Forms: Importing / VLOOKUP Data from Excel?

I am a bit new to Outlook forms, but not to VBA overall - nor HTML/Web design of forms. However, my problem is finding a way to combine the two.
I am trying to design a form for users to fill out, and based on what they fill out in drop-down box's, it will then tell them what we want them to attach in the email. Currently we have this done in Excel, based on dropbox's it then VLOOKUPS to the 2nd Spreadsheet that contains the forms required.
Is there anyway I can bring in the Excel with the VLOOKUP behind the scenes in my VBA Outlook Form so that it can look-up what attachments we want the user to do? Otherwise, it would be a TON of SELECT CASE statements in VBA =/
This seems to the do the trick for me.
Some of it I have cobbled together from sites like this, the rest has been created by myself from scratch.
When I click my button:
An input box appears, which is the value that will be looked up in the spreadsheet.
it looks in the range (specified in the code), for a match
returns the value, two columns to the left of it.
when it finds a match it puts it in the Subject line in Outlook.
Dim jobno As String
Dim Proj As String
Sub Test()
jobno = InputBox("Job Number?", "Test")
GetNameFromXL
If jobno <> "" Then
Set myItem = Application.CreateItem(0)
If Proj <> "" Then
myItem.Subject = jobno & " - " & Proj & " - " & Format(Date, "dd.mm.yy")
Else
myItem.Subject = jobno & " - " & Format(Date, "dd.mm.yy")
End If
myItem.Display
Else
Exit Sub
End If
End Sub
Sub GetNameFromXL()
'Late binding. No reference to Excel Object required.
Dim xlApp As Object
Dim xlWB As Object
Dim xlWS As Object
Set xlApp = CreateObject("Excel.Application")
'Open the spreadsheet to get data
Set xlWB = xlApp.Workbooks.Open("X:\...\FILENAME.xlsx") ' <-- Put your file path and name here
Set xlWS = xlWB.Worksheets(1) ' <-- Looks in the 1st Worksheet
Debug.Print "-----Start of 'For Each' loop"
For Each c In xlWS.Range("A6:A100") 'Change range to value you want to 'VLookUp'
Proj = c.Offset(0, 2).Value 'This looks at the 2nd column after the range above
Debug.Print c & Proj
If jobno = c Then
Debug.Print "-----Match Found: " & jobno & " = " & Proj
GoTo lbl_Exit
Else
End If
Next c
Debug.Print "-----End of For Each loop"
MsgBox jobno & " not found in WorkBook."
'Clean up
Set xlWS = Nothing
Set xlWB = Nothing
Set c = Nothing
Proj = ""
xlApp.Quit
Set xlApp = Nothing
lbl_Exit:
Exit Sub
End Sub

excel macro save sheets as csv with specific delimiter and enclosure

I am a total dummy as for vb and excel, have tried to combine 2 macros that I have found around here, into 1, but obviously did something terribly wrong and now i'm stuck.. First I just used this macro (saved it in as personal.xlsb so as to be able to use it in any workbook)
Sub CSVFile()
Dim SrcRg As Range
Dim CurrRow As Range
Dim CurrCell As Range
Dim CurrTextStr As String
Dim ListSep As String
Dim FName As Variant
FName = Application.GetSaveAsFilename("", "CSV File (*.csv), *.csv")
ListSep = ";"
If Selection.Cells.Count > 1 Then
Set SrcRg = Selection
Else
Set SrcRg = ActiveSheet.UsedRange
End If
Open FName For Output As #1
For Each CurrRow In SrcRg.Rows
CurrTextStr = ìî
For Each CurrCell In CurrRow.Cells
CurrTextStr = CurrTextStr & """" & GetUTF8String(CurrCell.Value) & """" & ListSep
Next
While Right(CurrTextStr, 1) = ListSep
CurrTextStr = Left(CurrTextStr, Len(CurrTextStr) - 1)
Wend
Print #1, CurrTextStr
Next
Close #1
End Sub
That plus the GetUTF8String function code. Now that was working fine. Then I have thought well why not just experiment with my limited (that is a serious understatement) vb understanding, added the following code and changed the CSVFile sub into a function, which I then called from the sub below, with the output file name as a parameter (to be used instead FName = Application.GetSaveAsFilename). I thought yeah, this code saves all sheets automatically, now let's just make sure that the encoding and delimiter/enclosure setting function runs before each sheet is saved. It doesn't seem right but I thought hey why not try..
Public Sub SaveAllSheetsAsCSV()
On Error GoTo Heaven
' each sheet reference
Dim Sheet As Worksheet
' path to output to
Dim OutputPath As String
' name of each csv
Dim OutputFile As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
' Save the file in current director
OutputPath = ThisWorkbook.Path
If OutputPath <> "" Then
Application.Calculation = xlCalculationManual
' save for each sheet
For Each Sheet In Sheets
OutputFile = OutputPath & Application.PathSeparator & Sheet.Name & ".csv"
' make a copy to create a new book with this sheet
' otherwise you will always only get the first sheet
Sheet.Copy
' this copy will now become active
CSVFile(OutputFile)
ActiveWorkbook.SaveAs Filename:=OutputFile, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Next
Application.Calculation = xlCalculationAutomatic
End If
Finally:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Exit Sub
Heaven:
MsgBox "Couldn't save all sheets to CSV." & vbCrLf & _
"Source: " & Err.Source & " " & vbCrLf & _
"Number: " & Err.Number & " " & vbCrLf & _
"Description: " & Err.Description & " " & vbCrLf
GoTo Finally
End Sub
Saved that and with that I have managed to achieve something very different. On opening any workbooks, that macro runs and opens up my sheets from that particular workbook as csv files (without saving them). Now I am like Alice in Wonderland. How come it is running on file open? That is not desirable, so I went back to the macro code and changed it back to just the csvfile sub. Well that didn't help, no idea what I did there, was definitely editing the same macro... So I deleted the macro, the modul, I cannot imagine where the thing now is but it's still running + I get this warning that macros were deactivated. Can't get rid of it! Now lads, I'm sorry for the total lack of professionality from my side, this was just supposed to be a small favor for a client, without wasting loads of time learning vb, coz my boss doesn't like that... I am of course interested in how to achieve the goal of saving the sheets automatically after setting the deimiter and enclosure in them. And at this moment I am very interested in how to get rid of that macro and where it is hiding.. What have I done?! Thank you for your patience!
I think the problem lies with the line
OutputPath = ThisWorkbook.Path
Because you are running this from your personal.xlsb which is stored in your XLSTART folder it has created the CSV files in the same location. When Excel starts it will try and load any files that it finds in that location.
Just locate your XLSTART folder and delete any CSV files you find there.
Try using
OutputPath = ActiveWorkbook.Path
XLSTART folder location, dependent on your system, is probably something like:
C:\Users\YOURNAME\AppData\Roaming\Microsoft\Excel\XLSTART