OBJECTIVE
Business units submit monthly financial information to Corporate each month. Develop a VBA macro that will pull in financial data from multiple business units.
APPROACH
Create a MASTER workbook that consolidates each business unit's information. Make sure that each business unit is represented in the MASTER workbook ("Target_workbook") with their own tab (e.g "1120", "1130", "1210"; "businessUnit")
Create an array from each of the business unit tabs ("arr")
Use array information to find corresponding Monthly financial report ("Source_Workbook", "Source_Path")
Copy and paste financial information into the MASTER workbook ("Target_workbook") and corresponding business unit's tab (businessUnit)
CODE
Sub getBusinessUnits()
Dim ws As Worksheet
Dim Target_Workbook As Workbook
Dim Source_Workbook As Workbook
Dim element As Variant
Dim col As New Collection
Dim Source_Path As String
Dim businessUnit As String
Dim businessName As String
'Set up collection to identify Business Unit Tabs and convert into array
For Each ws In ThisWorkbook.Worksheets
If IsNumeric(ws.Name) Then
col.Add ws.Name
Dim arr As Variant
End If
Next
arr = toArray(col) 'Collection converted into Array
'Loop through worksheets in array, open relative workbook, and pull in relevant data
For i = LBound(arr, 1) To UBound(arr, 1)
'assign business unit information to variables.
'Define workbook where we will paste copied information (target_workbook)
businessUnit = ThisWorkbook.Sheets(arr(i)).Activate
Set Target_Workbooks = ThisWorkbook.Sheets(arr(i))
businessName = ActiveSheet.Cells(2, 2)
'Open up the corresponding business unit's financial report, copy data
Source_Path = ThisWorkbook.Path & "\Business Unit Monthly Reporting Template_" & businessName & ".xlsx"
Set Source_Workbook = Workbooks.Open(Source_Path)
Source_Workbook.Sheets("Auth Expense Data Entry").Range("A1:H150").Copy
'Paste copied information from Source_Workbook into Target_workbook
Target_Workbook.Sheets(arr(i)).Range("A5").PasteSpecial Paste:=xlPasteValues '!!!ERROR: "Object Variable or With Block variable not set" !!!!
'Clear cache, close source_workbook
Application.CutCopyMode = False
Source_Workbook.Close (False)
End
Next
End Sub
'Function to convert collection into array
Function toArray(col As Collection)
Dim arr() As Variant
ReDim arr(1 To col.Count) As Variant
For i = 1 To col.Count
arr(i) = col(i)
Next
toArray = arr
End Function
ISSUES
Error # Line: Target_Workbook.Sheets(arr(i)).Range("A5").PasteSpecial Paste:=xlPasteValues, "Object Variable or With Block variable not set". Why is this the case? Is it because the arr(i) is a variant/string?
Any other suggestions for code improvement?
You have Set Target_Workbooks
, remove the s.
Related
As part of an automation project I am automating the updating of values within an excel file. There are multiple files to be updated and each of these has links to other files, usually links to around 20 files.
In order to streamline automation and optimise the process I need a list of all files each of the "documents to be updated" links to.
Is there a macro I can use other tool to export a list of links within an excel file. Even just printing it to somewhere within the excel file itself would be useful and allow me to map links across all files.
For clarity:
There are many formulas that reference external workbooks.
An example of one such formula:
VLOOKUP($D$7,'C:\DATA\[BalanceSheet-LevelsFlows-VO-M.xlsx]Position'!$A$1:$HA$9999,F4,FALSE)
There are more than 36000 formulas referencing external workbooks in one file. There are references to 8 external workbooks.
My aim is to get a list of these external workbooks.
Whilst it would be fast to do it manually in this instance I have over 30 of the files I need to list external references for and some of these reference over 30 external workbooks.
This is a one off process for mapping, it doesn't need to be elegant, just quicker than doing it manually.
Link Sources
LinkSources method
XlLink enumeration
The Code
Option Explicit
Sub testLinkSources()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim Data As Variant: Data = getLinkSources(wb)
If Not IsEmpty(Data) Then
Dim ws As Worksheet: Set ws = wb.Worksheets.Add
ws.Range("A1").Resize(UBound(Data)).Value = Data
End If
Dim arr As Variant: arr = LinkSourcesToArray(wb)
If Not IsEmpty(arr) Then
Debug.Print Join(arr, vbLf)
End If
End Sub
Function getLinkSources( _
wb As Workbook) _
As Variant
If Not IsEmpty(wb.LinkSources) Then
Dim arr() As Variant: arr = wb.LinkSources
Dim rCount As Long: rCount = UBound(arr)
Dim Data As Variant: ReDim Data(1 To rCount, 1 To 1)
Dim r As Long
For r = 1 To rCount
Data(r, 1) = arr(r)
Next r
getLinkSources = Data
End If
End Function
Function LinkSourcesToArray( _
wb As Workbook) _
As Variant
If Not IsEmpty(wb.LinkSources) Then
LinkSourcesToArray = wb.LinkSources
End If
End Function
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.
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"
I'm in the middle of writing a script that populates an excel spreadsheet with data from an MS Project file. I would like the script to recognize the title name of the MS Project columns as I have a number of custom columns with different names (custom number fields are populated with different names)
The code below was my attempt, but i'm getting an error when it comes to writing the value of the task column title to the sheet, am I doing something wrong here?
Sub PopulateSheet()
Dim Proj As MSProject.Application
Dim NewProj As MSProject.Project
Dim t As MSProject.Task
Dim xl as workbook
Dim s as worksheet
Dim Newsheet as worksheet
Set Xl = ThisWorkbook
BookNam = Xl.Name
Set Newsheet = Xl.Worksheets.Add
'Code to find and open project files
Set Proj = New MSProject.Application
MsgBox ("Please Select MS Project File for Quality Checking")
'Select Project File
FileOpenType = Application.GetOpenFilename( _
FileFilter:="MS Project Files (*.mpp), *.mpp", _
Title:="Select MS Project file", _
MultiSelect:=False)
'Detect if File is selected, if not then stop code
If FileOpenType = False Then
MsgBox ("You Havent Selected a File")
Exit Sub
End If
'Write the FileOpenType variant to two separate strings
NewProjFilePath = Left$(FileOpenType, InStrRev(FileOpenType, "\"))
NewProjFileName = Mid$(FileOpenType, InStrRev(FileOpenType, "\") + 1)
Newsheet.Name = NewProjFileName
Set s = Newsheet
'Populate spreadsheet header row with column titles from MS Project
s.Range("A1").Value = t.Number1 ***<-- Error '91' - Object variable or With block variable not set***
End Sub
Here is generic code that loops through the fields in the active task table and prints out the field headings as displayed in the table.
Sub GetTaskTableHeaders()
Dim t As Table
Set t = ActiveProject.TaskTables(ActiveProject.CurrentTable)
Dim f As TableField
For Each f In t.TableFields
If f.Field > 0 Then
Dim header As String
Dim custom As String
custom = Application.CustomFieldGetName(f.Field)
If Len(f.Title) > 0 Then
header = f.Title
ElseIf Len(custom) > 0 Then
header = custom
Else
header = Application.FieldConstantToFieldName(f.Field)
End If
Debug.Print "Field " & f.Index, header
End If
Next f
End Sub
Note that fields can be customized at the project level to be given a different title, or they can be customized at the table level. This code looks for both customizations and if neither is found, the field name is used.
Try the code below, explanation inside the code's comments:
Option Explicit
Sub PopulateSheet()
Dim Proj As MSProject.Application
Dim NewProj As MSProject.Project
Dim PjTableField As MSProject.TableField ' New Object
Dim PjTaskTable As MSProject.Table ' New Object
Dim t As MSProject.task
Dim xl As Workbook
Dim s As Worksheet
Dim Newsheet As Worksheet
Dim BookName As String
Dim FileOpenType
Dim NewProjFilePath As String, NewProjFileName As String
Set xl = ThisWorkbook
BookName = xl.Name
Set Newsheet = xl.Worksheets.Add
'Code to find and open project files
Set Proj = New MSProject.Application
MsgBox ("Please Select MS Project File for Quality Checking")
'Select Project File
FileOpenType = Application.GetOpenFilename( _
FileFilter:="MS Project Files (*.mpp), *.mpp", _
Title:="Select MS Project file", _
MultiSelect:=False)
'Detect if File is selected, if not then stop code
If FileOpenType = False Then
MsgBox ("You Havent Selected a File")
Exit Sub
End If
'Write the FileOpenType variant to two separate strings
NewProjFilePath = Left$(FileOpenType, InStrRev(FileOpenType, "\"))
NewProjFileName = Mid$(FileOpenType, InStrRev(FileOpenType, "\") + 1)
Newsheet.Name = NewProjFileName
Set s = Newsheet
' Open MS-Project File
Proj.FileOpen NewProjFilePath & NewProjFileName
Set NewProj = Proj.ActiveProject
' ===== New code Section =====
' set the Table object
Set PjTaskTable = NewProj.TaskTables(NewProj.CurrentTable)
' loop through all tablefields in table
For Each PjTableField In PjTaskTable.TableFields
If PjTableField.Field = pjTaskNumber1 Then ' check if currect field numeric value equals the numeric value of "Number1"
'Populate spreadsheet header row with column titles from MS Project
s.Range("A1").Value = PjTableField.Title ' populate "A1" with the field's title and
End If
Next PjTableField
End Sub
I am trying to add workbook objects to an array of workbooks
The array is of type public created in a separate module
Option Explicit
Public w() As Workbook
Public i As Integer
then i have the below procedure in a sub stored in a worksheet
Sub test_addwbobjects()
ReDim Preserve w(2)
Application.Workbooks("Quick analysis - Moneycontrol.xlsx").Activate
Set w(i) = ActiveWorkbook
'Set w(i) = Application.Workbooks("Quick analysis - Moneycontrol.xlsx")
i = i + 1
'ActiveSheet.Range("b2") = w(0).Sheets("CF analysis").Range("b2")
'ActiveSheet.Cells(1, 1) = w(i).Sheets("CF analysis").Range("b2")
'ActiveSheet.Range("b2") = w(1).Sheets("CF analysis").Range("b5")
End Sub
Context:
The workbook "Quick analysis - Moneycontrol.xlsx" contains a financial model of a company. I want to be able to compare financial information of multiple companies, so for that purpose I want to create a workbook object every time I paste a company's financials into the "Quick analysis - Moneycontrol.xlsx" workbook
I am currently getting the subscript out of range error.
Can anyone help me with this?
Thanks
Maybe this will help:
Public w As Collection
Sub Test_addWBObject()
Set w = New Collection
w.Add Item:=Workbooks("Quick analysis - Moneycontrol.xlsx"), _
Key:="MyUniqueKeyForThisWorkbook"
'Can use collection as this:
ThisWorkbook.Worksheets("Sheet1").Range("A1") = w(1).Worksheets("Sheet1").Range("C2")
'or this
ThisWorkbook.Worksheets("Sheet1").Range("A1") = w("MyUniqueKeyForThisWorkbook").Worksheets("Sheet1").Range("C2")
'or this
Dim wrkBk As Variant
For Each wrkBk In w
ThisWorkbook.Worksheets("Sheet1").Range("A1") = wrkBk.Worksheets("Sheet1").Range("C2")
Next wrkBk
'or this
Dim x As Long
For x = 1 To w.Count
ThisWorkbook.Worksheets("Sheet1").Range("A1") = w(x).Worksheets("Sheet1").Range("C2")
Next x
End Sub