I'm new to VBA. I have found code that copy and rename multiple template worksheets based on a list in a column (A1, A2, A3 etc). I tried modifying it to loop through a row instead, ie cells A1, B1, C1, D1, E1, but no luck. I want to copy multiple templates and rename them based on an account number entered via a user input form. I have created a worksheet, LedgerArray, that lists worksheet names for each account number. Example:
row1: 1Savings, 1Shares, 1Statement
row2: 2Savings, 2Shares, 2Statement
Thanks in advance
Hello Ambie, your effort is much appreciated, fluey infant especially. I developed the code below. It works as far as copying and renaming the templates, and assigning user input to specific template header cells. These tasks are intended for new accounts. A separate user form is intended for existing accounts. As you indicated, no error handling procedures are included (eg entry of a duplicate account number). Also, the section of the code that should transfer share transaction data to the first empty row in the renamed worksheet does not work. When executed, the code returns no syntax error but the result on the first empty row is blank.
Sub CommandButton1_Click()
Dim Template As String, str1 As String, str2 As String, str3 As String, str4 As String, str5 As String
Dim ws As Worksheet, lrShar As Long, lrSav As Long, lrTD As Long, lrStmnt As Long
str1 = "Shares"
str2 = "Savings"
str3 = "TimeDeposit"
str4 = "Loans"
str5 = "Statements"
'hide the form
frmAddSheet.Hide
'Select 1st template
Template = "TemplateShares"
'copy template to create a new sheet
Sheets(Template).Select
Sheets(Template).Copy After:=Sheets(Sheets.Count)
'make the sheet visible in case the template is hidden
ActiveSheet.Visible = xlSheetVisible
'Rename the sheet
ActiveSheet.Name = AccNumTextBox & str1
'Transfer Heading data
Set ws = Sheets(AccNumTextBox & str1)
ws.Range("A4") = AccNumTextBox.Value
ws.Range("B5") = DTPicker4.Value
ws.Range("B6") = Reference.Value
ws.Range("B7") = RegFeeTextBox.Value
ws.Range("B8") = NameTextBox.Value
ws.Range("B9") = AddressTextBox.Value
ws.Range("B10") = TelNumTextBox.Value
ws.Range("B11") = EmailTextBox.Value
ws.Range("B12") = ComboBox2.Value
ws.Range("B13") = DOBDTPicker.Value
'transfer Share transaction data
lrShar = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
ws.Range("A" & lrShar).Value = DTPicker4.Value
ws.Range("B" & lrShar).Value = Reference.Value
ws.Range("C" & lrShar).Value = SharesTextBox.Value
'Select 2nd template
Template = "TemplateSavings"
'copy template to create a new sheet
Sheets(Template).Select
Sheets(Template).Copy After:=Sheets(Sheets.Count)
'make the sheet visible in case the template is hidden
ActiveSheet.Visible = xlSheetVisible
'Rename the sheet
ActiveSheet.Name = AccNumTextBox & str2
'Transfer Heading data
Set ws = Worksheets(AccNumTextBox & str2)
ws.Range("A4") = AccNumTextBox.Value
ws.Range("B5") = DTPicker4.Value
ws.Range("B6") = Reference.Value
ws.Range("B7") = RegFeeTextBox.Value
ws.Range("B8") = NameTextBox.Value
ws.Range("B9") = AddressTextBox.Value
ws.Range("B10") = TelNumTextBox.Value
ws.Range("B11") = EmailTextBox.Value
ws.Range("B12") = ComboBox2.Value
ws.Range("B13") = DOBDTPicker.Value
'Select 3rd template
Template = "TemplateTimeDeposit"
'copy template to create a new sheet
Sheets(Template).Select
Sheets(Template).Copy After:=Sheets(Sheets.Count)
'make the sheet visible in case the template is hidden
ActiveSheet.Visible = xlSheetVisible
'Rename the sheet
ActiveSheet.Name = AccNumTextBox & str3
'Transfer Heading data
Set ws = Worksheets(AccNumTextBox & str3)
ws.Range("A4") = AccNumTextBox.Value
ws.Range("B5") = DTPicker4.Value
ws.Range("B6") = Reference.Value
ws.Range("B7") = RegFeeTextBox.Value
ws.Range("B8") = NameTextBox.Value
ws.Range("B9") = AddressTextBox.Value
ws.Range("B10") = TelNumTextBox.Value
ws.Range("B11") = EmailTextBox.Value
ws.Range("B12") = ComboBox2.Value
ws.Range("B13") = DOBDTPicker.Value
'Select 4th template
Template = "TemplateLoans"
'copy template to create a new sheet
Sheets(Template).Select
Sheets(Template).Copy After:=Sheets(Sheets.Count)
'make the sheet visible in case the template is hidden
ActiveSheet.Visible = xlSheetVisible
'Rename the sheet
ActiveSheet.Name = AccNumTextBox & str4
'Select 5th template
Template = "TemplateStatement"
'copy template to create a new sheet
Sheets(Template).Select
Sheets(Template).Copy After:=Sheets(Sheets.Count)
'make the sheet visible in case the template is hidden
ActiveSheet.Visible = xlSheetVisible
'Rename the sheet
ActiveSheet.Name = AccNumTextBox & str5
'Transfer Heading data
Set ws = Worksheets(AccNumTextBox & str5)
ws.Range("B8") = AccNumTextBox.Value
ws.Range("B9") = DTPicker4.Value
ws.Range("B10") = NameTextBox.Value
'Bring Data Entry sheet back to front if necesary
If chkBringToFront = False Then
Sheets("DataEntry").Select
End If
End Sub
As you're new to VBA, I've given an example that uses some aspects you might find useful in your coding future (a class and a collection).
Create a new class and call it cTemplate. Add the following properties:
Public Original As Worksheet
Public Suffix As String
Declare this module-level variable (ie at the top of your programme).
Private mTemplateList As Collection
Populate a collection with your template objects. (Note I've done this in a routing called "Initialise". If you don't have something similar then just call this routine in your Workbook_Open event).
I'd prefer to keep control of the template names, so you'll see that I've added them manually. In response to your question though, I've put a routine below it that reads the first row of a worksheet and takes out the template name, but it has no error handling and if anything should change in that list, your entire worksheet naming structure will be messed up.
Sub Initialise()
'
' /.../
'
Dim template As cTemplate
' Populate the collection with template and clone names.
Set mTemplateList = New Collection
Set template = New cTemplate
Set template.Original = ThisWorkbook.Worksheets("templateSavings")
template.Suffix = "Savings"
mTemplateList.Add template
Set template = New cTemplate
Set template.Original = ThisWorkbook.Worksheets("templateShares")
template.Suffix = "Shares"
mTemplateList.Add template
Set template = New cTemplate
Set template.Original = ThisWorkbook.Worksheets("templateStatements")
template.Suffix = "Statements"
mTemplateList.Add template
'
' Or if you really must read a row of previous worksheet names
' and you are certain the first row contains "1" then sheet name,
' use the following
'
Dim rng As Range
Dim cell As Range
dim str as String
Set mTemplateList = New Collection
' Quick and nasty row 1 selection -
' Adjust as you require for your own rows.
Set rng = ThisWorkbook.Worksheets("Sheet1").UsedRange.Resize(1)
' Read each cell to obtain the template sheet name
' Assumes each name has "1" and "template" at the start
For Each cell In rng.Columns
Set template = New cTemplate
str = Replace(cell.Text, "1", "")
Set template.Original = ThisWorkbook.Worksheets(str)
str = Replace(str, "template", "")
template.Suffix = str
mTemplateList.Add template
Next
End Sub
And finally, when a user adds a new account number, call the following routine.
Sub CreateNewTemplates(accountNumber As Long)
Dim template As cTemplate
Dim accountPrefix As String
Dim lastSheet As Worksheet
' Create prefix for worksheet names
accountPrefix = Format(accountNumber, "00000")
' Loop through the templates to copy
Set lastSheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
For Each template In mTemplateList
template.Original.Copy After:=lastSheet
ActiveSheet.Name = accountPrefix & template.Suffix
Set lastSheet = ActiveSheet
Next
End Sub
Worksheet objects need careful error handling and your routine will need to check for duplicate account names, missing templates, etc. The same applies to your row reader for worksheet names. I'm afraid I'm typing at night with a fluey infant on my lap and she's just stirring, so I'll leave that bit for you.
Related
I have built an Excel Workbook that is intended for evaluation of an organization as a whole and then evaluation of each of several sites for that organization. There is an initial assessment and then an on-site assessment for the organization, and for each facility. Depending on the organization, the number of facilities will vary. There is a first "Configuration" tab where the user of the workbook enters (or copies and pastes) the list of facilities and determines which facilities are to be included in the evaluation.
The second and third worksheets are the assessment for the organization as a whole, and the fourth and fifth worksheets are template assessment forms for the facilities.
Once the list of facilities is entered, the user clicks on a button labeled "Create Facility Tabs" that steps through the facility list and creates the needed worksheets for each facility.
If the list is fresh (starting from its initial form), then the template worksheets are renamed for the first facility and new worksheets are created for the remainder.
If there are already worksheets identified, the software checks each facility to see if its page already exists, and only creates additional worksheets for newly added facilities.
When additional worksheets are needed, the code first counts the number of additional worksheets that are needed (two for each facility), creates those worksheets, and then steps through them copying the template contents onto the forms and the change code for the worksheets into the worksheet's module.
The software works perfectly over and over again when I have the VBA window open. It does everything it is supposed to do. However, when I close the VBA window, the code creates all the worksheets, copies everything into the first worksheet, and then raises a Subscript Out of Range error. Any ideas what I am doing wrong?
Here is the code:
Public Sub CreateFacilities()
Dim row As Long
Dim facility_name As String
Dim facility_list As String
Dim facilities As Variant
Dim include As Boolean
Dim ws_init As Worksheet
Dim ws_fac As Worksheet
Dim ws_new_init As Worksheet
Dim ws_new_fac As Worksheet
Dim ws_config As Worksheet
Dim facility_count As Long
Dim tabs_to_create As Long
Dim fac_initial_range As Range
Dim fac_initial_address As String
Dim fac_onsite_range As Range
Dim fac_onsite_address As String
Dim message As String
Dim title As String
Dim answer As Variant
Dim code_line As String
Dim b_width As Long
Dim c_width As Long
Dim counter As Long
Dim init_sheet_number As Long
Dim fac_sheet_number As Long
Dim tab_count As Long
title = "Creating Facility Tabs"
message = "Before you execute this function you should" & vbCrLf & "add any study-specific questions to the" & vbCrLf
message = message & "Initial Assessment - Facility1 and" & vbCrLf & "On-Site Assessment - Facility1 tabs so" & vbCrLf
message = message & "they will be included on the created facility tabs" & vbCrLf & vbCrLf
message = message & "Do you wish to continue?"
answer = MsgBox(message, vbYesNo + vbQuestion, title)
If answer = vbNo Then
Exit Sub
End If
Set ws_config = ThisWorkbook.Sheets("Configuration")
Set ws_init = ThisWorkbook.Sheets(4)
Set ws_fac = ThisWorkbook.Sheets(5)
b_width = ws_init.Columns("B").ColumnWidth
c_width = ws_init.Columns("C").ColumnWidth
Set fac_initial_range = ws_init.Range("A1:C" & Trim(Str(FindLastRow(ws_init))))
Set fac_onsite_range = ws_fac.Range("A1:C" & Trim(Str(FindLastRow(ws_fac))))
fac_initial_address = fac_initial_range.address
fac_onsite_address = fac_onsite_range.address
code_line = ThisWorkbook.VBProject.VBComponents("Module1").CodeModule.Lines(1, 50) 'get code for each new worksheet
facility_list = "" 'get list of facilities
facility_count = 0
For row = 4 To 54
facility_name = ThisWorkbook.Sheets("Configuration").cells(row, 2).value
include = ThisWorkbook.Sheets("Configuration").cells(row, 4).value
If facility_name = "" Then 'reached the end of the list
Exit For
Else:
If include Then 'the Do Assessment column is marked TRUE
If Not WorksheetExists(facility_name) Then 'the tabs for this facility do not already exist
facility_list = facility_list & facility_name & ","
End If
End If
End If
Next row
facility_list = Left(facility_list, Len(facility_list) - 1) 'remove trailing comma
If facility_list = "" Then 'no new facilities were added to the list
MsgBox "There were no facilties specified for inclusion"
Exit Sub
End If
facilities = Split(facility_list, ",") 'there is a list of facilities to add
facility_count = UBound(facilities) + 1
If ActiveWorkbook.Sheets.Count = 5 Then 'no facility tabs have been added
If facility_count = 1 Then 'there is only one facility - no tabs need to be added
tabs_to_create = 0
facility_name = facilities(0)
ws_init.Name = CreateInitialTabName(facility_name)
ws_fac.Name = CreateOnSiteTabName(facility_name)
Else:
tabs_to_create = (facility_count - 1) * 2
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count), Count:=tabs_to_create
For counter = LBound(facilities) To UBound(facilities)
facility_name = facilities(counter)
If counter = 0 Then 'rename the first two facility worksheets that already exist
ws_init.Name = CreateInitialTabName(facility_name)
ws_fac.Name = CreateOnSiteTabName(facility_name)
Else: 'for the rest, add worksheets and copy template content and code
init_sheet_number = ((counter - 1) * 2) + 6
fac_sheet_number = init_sheet_number + 1
Set ws_new_init = ActiveWorkbook.Sheets(init_sheet_number) 'create initial assessment sheet for facility
ws_new_init.Columns("B").ColumnWidth = b_width
ws_new_init.Columns("C").ColumnWidth = c_width
ws_new_init.Name = CreateInitialTabName(facility_name)
fac_initial_range.Copy Destination:=ws_new_init.Range("A1")
ThisWorkbook.VBProject.VBComponents(ws_new_init.CodeName).CodeModule.AddFromString code_line
Set ws_new_fac = ActiveWorkbook.Sheets(fac_sheet_number) 'create on-site assessment sheet for facility
ws_new_fac.Columns("B").ColumnWidth = b_width
ws_new_fac.Columns("C").ColumnWidth = c_width
ws_new_fac.Name = CreateOnSiteTabName(facility_name)
fac_onsite_range.Copy Destination:=ws_new_fac.Range("A1")
ThisWorkbook.VBProject.VBComponents(ws_new_fac.CodeName).CodeModule.AddFromString code_line
End If
Next counter
End If
Else: 'there are more than 5 tabs in the workbook - some were already added
tab_count = ActiveWorkbook.Sheets.Count
tabs_to_create = facility_count * 2
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(tab_count), Count:=tabs_to_create
For counter = LBound(facilities) To UBound(facilities)
facility_name = facilities(counter)
init_sheet_number = (counter * 2) + (tab_count + 1)
fac_sheet_number = init_sheet_number + 1
Set ws_new_init = ActiveWorkbook.Sheets(init_sheet_number)
Set ws_new_fac = ActiveWorkbook.Sheets(fac_sheet_number)
ws_new_init.Name = CreateInitialTabName(facility_name)
ws_new_fac.Name = CreateOnSiteTabName(facility_name)
ws_new_init.Columns("B").ColumnWidth = b_width
ws_new_fac.Columns("B").ColumnWidth = b_width
ws_new_init.Columns("C").ColumnWidth = c_width
ws_new_fac.Columns("C").ColumnWidth = c_width
fac_initial_range.Copy Destination:=ws_new_init.Range("A1")
fac_onsite_range.Copy Destination:=ws_new_fac.Range("A1")
ThisWorkbook.VBProject.VBComponents(ws_new_init.CodeName).CodeModule.AddFromString code_line
ThisWorkbook.VBProject.VBComponents(ws_new_fac.CodeName).CodeModule.AddFromString code_line
Next counter
End If
ws_config.Activate
MsgBox Str(facility_count) & " facilities added"
End Sub
I have a list of files with the same structure and I want to extract some information from columns A, B, and C and print it to another workbook.
I found a way to do it for a single file, but now I don't understand how can I do it using the list of given files. I tried using collections, but it doesn't work.
Here's what I came up with:
Sub Pulsante1_Click()
Dim FileGeStar As Variant
Dim myCol As Collection
Set myCol = New Collection
myCol.Add "C:\Users\xxx\Desktop\articoli_def.xlsx"
myCol.Add "C:\Users\xxx\Desktop\pippo\SS20_def_ENG.xlsx"
For Each FileGeStar In myCol
Workbooks.Open Filename:=FileGeStar
FileGeStar = Application.ActiveWorkbook.Name
Dim Code As String
Dim Description As String
Dim FilePath As String
Dim i As Long
i = 2
While Range("A" & i) <> ""
FilePath = Application.ActiveWorkbook.Path
Code = Trim(Range("A" & i).Value)
Description = Trim(Range("B" & i).Value)
Workbooks("Report.xlsm").Worksheets(1).Range("A" & i).Value = FilePath
Workbooks("Report.xlsm").Worksheets(1).Range("B" & i).Value = Code
Workbooks("Report.xlsm").Worksheets(1).Range("C" & i).Value = Description
i = i + 1
Wend
Next FileGeStar
End Sub
What can I do?
This might look like an overkill, but I hope the code and comment's are self explanatory:
Option Explicit
Sub Pulsante1_Click()
Dim DestinationWorkbook As Workbook
Set DestinationWorkbook = ThisWorkbook 'I think report.xlsm is the workbook running the code
'if report.xlsm is not the workbook running the code then change thisworkbook for workbooks("Report.xlsm")
'add as many paths as you need to, another way would be to write them in a sheet and loop through to fill the array
Dim MyPaths As Variant
MyPaths = Array("C:\Users\xxx\Desktop\articoli_def.xlsx", "C:\Users\xxx\Desktop\pippo\SS20_def_ENG.xlsx")
'Declare a workbook variable for the source workbooks
Dim SourceWorkbook As Workbook
'Declare a long variable to loop through your path's array
Dim i As Long
'loop through the start to the end of your array (will increase as the array does)
For i = LBound(MyPaths) To UBound(MyPaths)
Set SourceWorkbook = OpenWorkbook(MyPaths(i)) 'this will set the workbook variable and open it
CopyData SourceWorkbook, DestinationWorkbook 'this will copy the data to your destination workbook
SourceWorkbook.Close , False
Set SourceWorkbook = Nothing
Next i
End Sub
Private Function OpenWorkbook(FullPath As String) As Workbook
Set OpenWorkbook = Workbooks.Open(FullPath, False, True)
End Function
Private Sub CopyData(wbO As Workbook, wbD As Workbook)
'this procedure calculates the last row of your source workbook and loops through all it's data
'later calls the AddDataToMasterWorkbook procedure to paste the data
With wbO.Sheets(1) 'Im assuming your source workbook has the data on sheet1
Dim LastRow As Long
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Dim FilePath As String
FilePath = wbO.Path
Dim Code As String
Dim Description As String
Dim C As Range
For Each C In .Range("A2:A" & LastRow) 'this will loop from A2 to the last row with data
Code = Trim(C)
Description = Trim(C.Offset(, 1))
AddDataToMasterWorkbook wbD, FilePath, Code, Description
Next C
End With
End Sub
Private Sub AddDataToMasterWorkbook(wb As Workbook, FilePath As String, Code As String, Description As String)
'This procedure calculates the last row without data and adds the items you need every time
With wb.Sheets(1)
Dim LastRow As Long
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Range("A" & LastRow) = FilePath
.Range("B" & LastRow) = Code
.Range("C" & LastRow) = Description
End With
End Sub
To loop though files, you can indeed use a collection, or an array, you can also loop through all files in directory with certain extension, or partial file name. Check out DIR function.
Best not to use ActiveWorkbook, better approach would be to set a workbook object like so: Set wb = Workbooks.Open(fullPathToYourWorkbook).
For what you're doing, there's no need to go row by row, much more efficient way would be to copy entire range, not only it's a lot quicker but also it's only 1 line of code; assuming your destination is ThisWorkbook.Sheets(1) and wb object is set: wb.Range("A:C").Copy Destination:=Thisworkbook.Sheets(1).Range("A:C"). If you need to edit copied data (trim or whatever) consider Range Replace method.
However, if you want to go row by row for whatever reason, as BigBen mentioned in the comment - get rid of While loop.
It's a good idea to set Application.ScreenUpdating to False when opening/closing workbooks, then back to True once it's all done. It will prevent user from accidentaly clicking something etc and will make it look like it's not opening any workbook.
Here's my approach (untested) assuming the workbook you want to copy data to is Workbooks("Report.xlsm").Worksheets(1):
Sub Pulsante1_Click()
'set workbook object for the destination workbook
set wb_dest = Workbooks("Report.xlsm").Worksheets(1)
'disable screen updating
Application.ScreenUpdating = False
For Each target_wb In Array("C:\Users\xxx\Desktop\articoli_def.xlsx", "C:\Users\xxx\Desktop\pippo\SS20_def_ENG.xlsx")
'set wb object and open workbook
Set wb = Workbooks.Open(target_wb)
'find last row in this workbooks in columns A:B (whichever is greater)
LastRow = wb.Range("A:B").Find(What:="*", After:=wb.Range("A1"), SearchDirection:=xlPrevious).row
'copy required data
wb.Range("A1:B" & LastRow).Copy Destination:=wb_dest.Range("B1:C" & LastRow)
'fill column A with path to the file
wb_dest.Range("A1:A" & LastRow).Value = wb.Path
'close workbook
wb.Close False
Next
'enable screen updating
Application.ScreenUpdating = True
End Sub
Obviously an array is not the best approach if you have loads of different files, collection would be a lot clearer to read and edit in the future, unless you want to create a dynamic array, but there's no need for that in my opinion. I didn't declare variables or write any error handling, it's a simple code just to point you in the right direction.
If you want to disable workbook events or/and alerts, you can set Application.DisplayAlerts and Application.EnableEvents to False temporarily.
In my code, I select items from my workbook and create a new workbook to paste the selected items within. I then call another sub (Callothers) using an argument to pass along this new workbook such that the remaining code runs in the new workbook. However, rather than run in the new workbook, the rest of the code occurs in the original.
I have messed with the argument, however I am not reaching a solution.
Sub occurences()
'sort
Set oldbook = ActiveWorkbook
lRow = Cells(Rows.Count, 42).End(xlUp).Row 'Finds the last used row
Dim coll As New Collection 'Collections are similar to arrays, but you don't need to declare a size
For Row = 2 To lRow 'Loop through each row
newitem = Sheets("Sheet1").Cells(Row, 42) 'Grab the contents of the row
flag = False 'flag will be false unless we find a match in our collection
For Each Item In coll 'loop through our collection
If Item = newitem Then 'check for a match
flag = True 'if there is a match, set flag
End If
Next Item
If flag = False Then 'if a match wasn't found,
coll.Add newitem 'add the new item to the collection
End If
Next Row 'now go to the next row and start again
MsgBox (coll.Count) 'this tells us how many items are in the collection
For Each Item In coll 'this displays each item in the collection
Set newbook = Workbooks.Add
MsgBox ("oldbook a2 = " & oldbook.Sheets("Sheet1").Range("A2"))
With newbook
Row = 1
oldbook.Sheets("Sheet1").Range("a1:ar1").Copy .Sheets("Sheet1").Rows(Str(Row))
nRow = 2
For Row = 2 To lRow
If oldbook.Sheets("Sheet1").Cells(Row, 42) = Item Then
oldbook.Sheets("Sheet1").Rows(Str(Row)).Copy .Sheets("Sheet1").Rows(Str(nRow))
nRow = nRow + 1
End If
Next Row
fname = Replace(Item, " ", "-")
fname = fname & ".xlsx"
MsgBox ("about to call")
Call CallOthers(newbook)
.SaveAs Filename:=fname '("C:\Users\Joshua.Elphee\Desktop\TEST Save\" & fname)
.Close
End With
Next Item
End Sub
Sub CallOthers(newbook)
Call Delete_Rows_Based_On_Value(newbook)
Call Delete_Rows_Based_On_Value1(newbook)
End Sub
No error message, just performs the actions within the wrong workbook
You need put more info, but if idea is: You have 2 workbooks OLDBook and NEWBook , you extract info from OLDBook and put in NEWBook then use "Call Sub OTHER()" and you problem is that instead delete rows in NEWBook delete rows in OLDBook . For you, problem is in your code OTHER but you dont put here (maybe is top secret XD) so you need are explicit sentences like OLDBook.Sheets(1) and NEWBook.close then be sure active workbook you are using like OLDBook.active because when you use .ADD you create a variable as workbooks (collection) that have 2 elements workbook OLDBook and workbook OLDBook ; however if you dont like use this way you also can use public variables on top your module put
Public OLDBook as workbook
Public OLDBook as workbook
so only you need to use inside your sub()
Set OLDBook = ActiveWorkbook
Set NEWBook = new Workbooks
or if you have path
OLDBook.open "C:\T\"
NEWBook = new Workbook
NEWBook.open
I have a PowerApp which updates a cell in an Excel file hosted in OneDrive. The Excel file contains a macro that is supposed to run when the PowerApp changes the Excel file. However, it doesn't do that. If I update a cell manually, the macro works just fine. It's just not activated when the file is updated by PowerApps.
Is there a different function I can use that will be triggered when PowerApp changes the file?
If that is not possible, could I use a Flow to activate the macro?
Here is the current script that works with manual changes, but not the automatic PowerApps changes.
Private Sub Worksheet_Change(ByVal Target As Range)
Call InsertImageTest
End Sub
Here is the macro that I want to trigger using the code above.
Sub InsertImageTest()
' This macro inserts an image from a set location to a set cell.
Dim ws As Worksheet
Dim imagePath As String
Dim cell As String
Dim posText As String
Dim imgLeft As Double
Dim imgTop As Double
Dim rngX As Range
Dim activeSheetName As String
' Customizable variables
imagePath = ActiveWorkbook.Path & Range("$B$2").Value
posText = "Signature"
activeSheetName = "Data" ' Set to "Data" by default, but will change to the Active sheets name, if the active sheet is not called "Data"
' For i = 1 To Sheets.Count
' If CStr(Sheets(i).Name) Is CStr(activeSheetName) Then
' Debug.Print "Code can be executed! Data tab was found"
' End If
' Next i
cell = "$A$1"
Set ws = ActiveSheet
Set rngX = Worksheets(activeSheetName).Range("A1:Z1000").Find(posText, lookat:=xlPart)
If Not rngX Is Nothing Then
cell = rngX.Address
Debug.Print cell
Debug.Print rngX.Address & " cheating"
Worksheets(activeSheetName).Range(cell).Value = ""
Debug.Print rngX.Address & " real"
imgLeft = Range(cell).Left
imgTop = Range(cell).Top
' Width & Height = -1 means keep original size
ws.Shapes.AddPicture _
Filename:=imagePath, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=imgLeft, _
Top:=imgTop, _
Width:=-1, _
Height:=-1
End If
' The code beaneath will resize the cell to fit the picture
For Each Picture In ActiveSheet.DrawingObjects
PictureTop = Picture.Top
PictureLeft = Picture.Left
PictureHeight = Picture.Height
PictureWidth = Picture.Width
For N = 2 To 256
If Columns(N).Left > PictureLeft Then
PictureColumn = N - 1
Exit For
End If
Next N
For N = 2 To 65536
If Rows(N).Top > PictureTop Then
PictureRow = N - 1
Exit For
End If
Next N
Rows(PictureRow).RowHeight = PictureHeight
Columns(PictureColumn).ColumnWidth = PictureWidth * (54.29 / 288)
Picture.Top = Cells(PictureRow, PictureColumn).Top
Picture.Left = Cells(PictureRow, PictureColumn).Left
Next Picture
End Sub
Unfortunately the server opens Excel through APIs and Excel doesn't fire macros in this way. It seems flow has the same. I would consider implement the macro function logic in PowerApps. Customize the edit form of the column which supposes to trigger the macro, depends what the macro should do. Possibly unlock a data card if the macro trys to alter a value of another column.
I have a file (F) that contains several workbooks, each workbook has the same format. I do a conditional sum on each of the workbook under column conditions. I want to put the output within another workbook that contains one worksheet per workbook looped (contained within F).
I cannot find the good strategy to change the worksheet name in function of the looped workbook' name.
Set Output_tot_n = Workbooks("Final_Output").Sheet_name.Range("B7")
I got
Error 438 "Object doesn't support this property or method"
The whole code:
Sub Proceed_Data()
Dim FileSystemObj As Object
Dim FolderObj As Object
Dim fileobj As Object
Dim Sheet_name As Worksheet
Dim i, j, k As Integer
Dim wb As Workbook
Set FileSystemObj = CreateObject("Scripting.FileSystemObject")
Set FolderObj = FileSystemObj.GetFolder("C:\...\")
For Each fileobj In FolderObj.Files
Set wb = Workbooks.Open(fileobj.Path)
Set Output_tot_n = Workbooks("Final_Output").Sheet_name.Range("B7")
If wb.Name = "AAA_SEPT_2018" Then
Sheet_name = Worksheets("AAA")
End If
If wb.Name = "BBB_SEPT_2018" Then
Sheet_name = Worksheets("BBB")
End If
If wb.Name = "CCC_SEPT_2018" Then
Sheet_name = Worksheets("CCC")
End If
' conditional sum
With wb.Sheets("REPORT")
For i = 2 To .Cells(Rows.Count, 14).End(xlUp).Row
If .Cells(i, "O").Value = "sept" Then
k = .Cells(i, "M").Value
End If
j = j + k
k = 0
Next i
End With
Output_tot_n = j
j = 0
wb.Save
wb.Close
Next fileobj
End Sub
Workbooks is a collection (part of the actual Application-object). A collection in VBA can be accessed either by index number (index starts at 1) or by name. The name of an open Workbook is the name including the extension, in your case probably either Final_Output.xlsx or Final_Output.xlsm.
Sheets and Worksheets are collections within a Workbook, again accessed via index or name (the difference is that Worksheets contains "real" spreadsheets while Sheets may also contain other sheet types, eg charts).
So in your case, you want to access a Range of a specific sheet of a specific workbook. The workbook has a fixed name, while the sheet name is stored in a variable. You can write for example
dim sheetName as string, sheet as Worksheet, Output_tot_n as Range
sheetName = "AAA" ' (put your logic here)
set sheet = Workbooks("Final_Output.xlsm").Worksheets(Sheet_name)
set Output_tot_n = sheet.Range("B7")
or put all together (depending on your needs)
set Output_tot_n = Workbooks("Final_Output.xlsm").Worksheets(Sheet_name).Range("B7")
No it actually works. Thank you again for your answers.
the problem was just is important to put "AAA_SEPT_2018.xlsx"