I am trying to reference all of the worksheets in another workbook implicitly without using direct references. The code I am working with is to be used to reference books of varying size, so defining a range rigidly is not optimal here.
I suppose you could say im looking for something like
'[Book.xlsx]ALL'!A1
or
'[Book.xlsx]*'!A1
Tl:dr i want a formula to look at every cell in a given range in a book without having to rigidly define every sheet it needs to look at in the formula. Context is VLOOKUP.
I think something like this can do the job :
Sub loopOverWoorkbookWorksheet()
Dim directory As String
Dim StrFile, wbs() As String
Dim i As Integer
Dim ws As Worksheet
' Getting all the xlsx file from your directory
directory = "your_directory"
i = 0
StrFile = Dir(directory & "\*.xlsx")
Do While Len(StrFile)
ReDim Preserve wbs(i)
wbs(i) = StrFile
StrFile = Dir
i = i + 1
Loop
' Loop through all the sheet of one workbook
For Each wb In wbs
workbooks.Open Filename:=directory & "\" & wb
For Each ws In Application.ActiveWorkbook.Sheets
' Do your compute
' You can store the result in a Cell using :
' Cells(x,y) = z
' x : number of the line
' y : number of the column
' z : the data you want to store in the cell
Next ws
Next wb
End Sub
Related
Imagine I have a file that already has macros in it which is applied to the data. I want to split that file into multiple files based on the region column such a way that I have to keep all the macro functions in that split files also from the original file. Please tell me the way to do it in VBA.
Sub SplitEachWorksheet()
Dim FPath As String
FPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Sheets
ws.Copy
Application.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF,
Filename:=FPath & "\" & ws.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
But I don't know-how to split by keeping macro functionalities from original file. please tell me how to do that.
If you want to do that in VBA, I would suggest you write code to:
Find all the values from the Region column
For each region:
Make a full copy of the original file (including the macro's)
Delete all rows which don't belong to that region
You'll have to put the macro which does the splitting and copying in a separate workbook.
I will assume that the region is in the first column of the first Sheet, and that all relevant data is on the first sheet. You will have to change that in the code to match the position in your workbook
And I assume that the original workbook is not opened. You may want to close it in your code.
Sub kopieer()
Dim macro_wb As Workbook
Dim macro_ws As Worksheet
Dim orig_wb As Workbook
Dim orig_ws As Worksheet
Dim orig_range As Range
Dim origpath As String
Dim origname As String
Dim region_wb As Workbook
Dim region_ws As Worksheet
Dim region As String
Dim region_wb_name As String
Dim region_row As Integer
Application.ScreenUpdating = False
origname = "D:\Oefen\test\Test_0.xlsm"
' Use this workbook to find the regions
Set macro_wb = ThisWorkbook
Set macro_sheet = Sheet1
macro_sheet.Cells.Clear
Set orig_wb = Application.Workbooks.Open(Filename:=origname)
origpath = orig_wb.Path
' Assuming the region is in first column of first Sheet
Set orig_ws = orig_wb.Sheets(1)
Set orig_range = orig_ws.Range([A2], [A2].End(xlDown))
orig_range.Copy (Sheet1.[A1])
orig_wb.Close
' Now we have all regions in column 1 of first sheet
Sheet1.Range([A1], [A1].End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
' loop throught the regions
For row = 1 To Sheet1.[A1].End(xlDown).row
region = Sheet1.Cells(row, 1)
' Make a full copy of the original file (including the macro's)
region_wb_name = origpath + "\" + region + ".xlsm"
FileCopy origname, region_wb_name
' Delete all rows which don't belong to that region
Set region_wb = Application.Workbooks.Open(region_wb_name)
Set region_ws = region_wb.Sheets(1)
' We are deleting rows, so we should start at the bottom
For region_row = region_ws.[A2].End(xlDown).row To 2 Step -1
If region_ws.Cells(region_row, 1).Value <> region Then
region_ws.Rows(region_row).Delete
End If
Next region_row
region_wb.Save
region_wb.Close
Next row
Application.ScreenUpdating = True
End Sub
I'm trying to:
Copy data (columns A and B) from one workbook (data.xlsx).
Paste into a new workbook (as values).
Save as CSV with a filename taken from column A in a third workbook (URLs.xlsx).
Process to repeat, taking the same data (which is randomised every time it is pasted) from data.xlsx and pasted into a new CSV - there are 200 rows in URLs.xlsx and so we should end up with 200 files.
I've read lots of topics, here are two I found:
Excel VBA Copy a Range into a New Workbook
https://www.excelcampus.com/vba/copy-paste-another-workbook/
What I've tried
Copying code and replacing the relevant components from various different articles across the web. Some of them work, but when I add the missing bits, I run into errors I don't understand.
Well here is an example avoiding copy pasting in new workbooks:
Expected input like:
Data.xlsx range A1:B200 with RANDBETWEEN() function:
URLs.xlsx range A1:A200 with some URL like so:
Run this code (will take approximately 1 second on my machine, tested with timer):
Dim wbData As Workbook, WBurls As Workbook
Dim CSVFileDir As String, CSVVal As String
Dim A As Long, X As Long, Y As Long, Z As Long
Option Explicit
Sub Transfer2CSV()
Set wbData = Workbooks("data.xlsx") 'Make sure it is open upon running macro
Set WBurls = Workbooks("URLs.xlsx") 'Make sure it is open upon running macro
For X = 1 To 200 'Looping through the 200 rows of WBurls
CSVFileDir = "C:\YourDrive\" & WBurls.Sheets(1).Cells(X, 1).Value & ".csv"
CSVVal = ""
A = FreeFile
Open CSVFileDir For Output As #A
With wbData.Sheets(1).Range("A1:B200") ' or whichever range you using here
.Calculate 'Randomize your range again
For Y = 1 To 200 'or however many rows you have in column A and B.
For Z = 1 To 2
CSVVal = CSVVal & .Cells(Y, Z).Value & ","
Next Z
Print #A, Left(CSVVal, Len(CSVVal) - 2)
CSVVal = ""
Next Y
End With
Close #A
Next X
End Sub
Output:
With each file looking like:
This should work. Make sure your data and URLS workbooks are open.
Sub Macro1()
Dim wsData As Worksheet, wsUrl As Worksheet, wbNew as Workbook
Dim CSVDir as String, rngU As Range
Set wsData = Workbooks("data.xlsx").Worksheets(1)
Set wsUrl = Workbooks("URLs.xlsx").Worksheets(1)
Set rngU = wsUrl.Range("A1", wsUrl.Range("A" & wsUrl.Rows.Count).End(xlUp))
CSVDir = "C:\Users\thomas.mcerlean\Desktop\Work\" 'you gave this as your dir
Set wbNew = Workbooks.Add
For Each cell In rngU
wsData.Range("A1", wsData.Range("B" & wsData.Rows.Count).End(xlUp)).Copy Destination:= wbNew.Worksheets(1).Range("A1")
wbNew.SaveAs Filename:= CSVDir & cell.Value & ".csv", FileFormat:=xlCSV
Next cell
wbNew.Close SaveChanges:=False
End Sub
I am looking at building a master workbook which receives a monthly dump of data for all Cost Centres which will then populate a large number of worksheets within the workbook, and which then need to be split off and sent out to service heads. A service head will receive a selection of worksheets based on the first 4 characters of the sheet name (although this may change in due course).
eg 1234x, 1234y, 5678a, 5678b will produce two new workbooks named 1234 and 5678 with two sheets in each.
I have cobbled some code from various forum to create a macro that will work through a hard coded array defining the service head 4 character codes and create a series of new workbooks. And which seems to work.
However.. I also need to include the main data dump sheet within the source file (called "data") with the the array of files being copied over so that the links remain with the data sheet being copied over. If I write a line to copy over the data sheet separately, the new workbook still refers back to the source file, which service heads do not have access to.
So main question is: how can I add the "data" tab into the Sheets(CopyNames).Copy code so it is copied over with all the other files in the array at the same to keep the links intact?
Second question is if I decide it is the first two characters of the worksheet define the sheets that relate to a service head, how do I tweak the split/mid line of code - I've trialled around but am getting tied up in knots!
Any other tips to make the code more elegant much appreciated (there may be quite a long list of service head codes and I am sure there is a better way of creating a list for the routine to loop through)
Sub Copy_Sheets()
Dim strNames As String, strWSName As String
Dim arrNames, CopyNames
Dim wbAct As Workbook
Dim i As Long
Dim arrlist As Object
Set arrlist = CreateObject("system.collections.arraylist")
arrlist.Add "1234"
arrlist.Add "5678"
Set wbAct = ActiveWorkbook
For Each Item In arrlist
For i = 1 To Sheets.Count
strNames = strNames & "," & Sheets(i).Name
Next i
arrNames = Split(Mid(strNames, 2), ",")
'strWSName =("1234")
strWSName = Item
Application.ScreenUpdating = False
CopyNames = Filter(arrNames, strWSName, True, vbTextCompare)
If UBound(CopyNames) > -1 Then
Sheets(CopyNames).Copy
ActiveWorkbook.SaveAs Filename:=strWSName & " " & Format(Now, "dd-mmm-yy h-mm-ss")
ActiveWorkbook.Close
wbAct.Activate
Else
MsgBox "No sheets found: " & strWSName
End If
Next Item
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub CopySheets()
With ThisWorkbook
Dim SheetIndex As Long
Dim ValidSheetNames() As String
ReDim ValidSheetNames(1 To .Worksheets.Count)
' Build a 1 dimensional array called ValidSheetNames, which contains every sheet in the master workbook other than DEDICATEDSHEET. '
Dim ws As Worksheet
For Each ws In .Worksheets
If ws.Name <> "DEDICATEDSHEET" Then
SheetIndex = SheetIndex + 1
ValidSheetNames(SheetIndex) = ws.Name
End If
Next ws
ReDim Preserve ValidSheetNames(1 To SheetIndex)
' Read all ServiceCodes into a 1-dimensional array '
Dim ServiceHeadCodes As Variant
ServiceHeadCodes = Application.Transpose(.Worksheets("DEDICATEDSHEET").Range("CCLIST[CC]").Value2)
Dim CodeIndex As Long
' Now loop through each ServiceHeadCode '
For CodeIndex = LBound(ServiceHeadCodes) To UBound(ServiceHeadCodes)
' Put all sheet names which contain the current ServiceHeadCode into an array called SheetsToCopy '
Dim SheetsToCopy() As String
SheetsToCopy = Filter(ValidSheetNames, ServiceHeadCodes(CodeIndex), True, vbTextCompare)
' Check if SheetToCopy now contains any sheet names at all. '
If UBound(SheetsToCopy) > -1 Then
' Add the name of the Data sheet to the end of the array '
ReDim Preserve SheetsToCopy(LBound(SheetsToCopy) To (UBound(SheetsToCopy) + 1))
SheetsToCopy(UBound(SheetsToCopy)) = "Data"
Dim OutputWorkbook As Workbook
Set OutputWorkbook = Application.Workbooks.Add
' Copy all sheets which are in SheetToCopy array to newly created OutputWorkbook '
.Worksheets(SheetsToCopy).Copy OutputWorkbook.Worksheets(1)
' Delete the default Sheet1, which should be at the end as copied sheets were inserted before it. '
' But suppress the Are you sure you want to delete this sheet.. message. '
Application.DisplayAlerts = False
OutputWorkbook.Worksheets(OutputWorkbook.Worksheets.Count).Delete
Application.DisplayAlerts = True
' Re-enable alerts, as we want to see any other dialogue boxes/messages
' Not providing a full directory path below means OutputWorkbook will be saved wherever Thisworkbook is saved.'
OutputWorkbook.SaveAs Filename:=ServiceHeadCodes(CodeIndex) & " " & Format(Now, "dd-mmm-yy h-mm-ss") & ".xlsx", FileFormat:=51
OutputWorkbook.Close
Else
MsgBox "No sheets found: " & ServiceHeadCodes(CodeIndex)
End If
Next CodeIndex
End With
End Sub
Untested and written on mobile, sorry for bad formatting.
This approach proposes that you store all service head codes in a 1-column Excel table on a dedicated sheet that is referred to via Excel table nomenclature (which might be easier than ArrayList.Add for each new service head code).
I assume code is stored in master workbook ('thisworkbook'), which might not be true.
You could modify the serviceheadcodes table directly on the spreadsheet itself, if you later decide that SheetsToCopy will be determined by first 2, 3 or X characters -- or you could modify array itself with left$() function.
Hope it works or gives you some ideas.
Edit: This is my sheet and table layout (which I assume matches yours).
And this is what the code above gives me on my computer.
I have written a code that opens a password protected workbook in a folder, copy some values out of it and paste the values in active woorkbook. This works fine.
My problem is that I have 16 password protected files in this folder, and I need a loop that does the same thing with every file. Below you can find the code, and I think all my problems should be properly explained with comments inside the code. Please ask if anything is unclear. In advance, thanks for any help!
Code:
Sub Bengt()
Dim sPath As String
Dim vFolder As Variant
Dim sFile As String
Dim sDataRange As String
Dim mydata As String
Dim wb As Workbook
Dim WBookOther As Workbook
Dim myArray As Variant '<<does the list of passwords have to be array?
sPath = ThisWorkbook.Path & Application.PathSeparator
sDataRange = "Budsjett_resultat'!E2" '<<every file I want to open has data in this sheet and range
sFile = "BENGT.xlsm" '<< how to make sFile be every file in folder?
' here I want a loop that opens every woorkbook in the folder M::\SALG\2016\Budsjett\
Set WBookOther = Workbooks.Open(sPath & sFile, Password:="bengt123")
' all passwords starts with filename + three numbers after as you can see
' here I want to make excel find the password out of a list of passwords in range B100:B116
mydata = "='" & sPath & "[" & sFile & "]" & sDataRange
'mydata = "='M:\SALG\2016\Budsjett\Bengt.xlsmBudsjett_resultat'!E2:E54" '<< change as required
'link to worksheet
With ThisWorkbook.Worksheets(1).Range("T2:T54")
'in this case I want the loop to find "BENGT"(which is the filename) in cell T1, and paste the values in range T2:T54.
'For the other files, I want the loop to find the filename (of the file it opened) in row 1,
'and paste the values in range ?2-?54 at the column with the same name as the filename
.Formula = mydata
.Value = .Value
WBookOther.Close SaveChanges:=False
End With
End Sub
For the password array I have tried following code:
Sub passord()
Dim myArray As Variant
myArray = ThisWorkbook.Worksheets(1).Range("B100:B116")
On Error Resume Next 'turn error reporting off
For i = LBound(myArray, 1) To UBound(myArray, 1)
Set wb = Workbooks.Open("M:\SALG\2016\Budsjett\BENGT.xlsm", Password:=myArray(i, 1))
If Not wb Is Nothing Then bOpen = True: Exit For
Next i
End Sub
I have tried to implement the last sub into the first sub, but I can't figure out how to make it work.
I am creating a function that reads column titles from two excel files and then place those column titles in checkboxes so the user can check which columns he will work with. It works when I do it with one file but when I modify it to work with two files I get the "run time error 9: Subscript out of range" and highlights the line => Set wks2 = ActiveWorkbook.Worksheets(SheetName2).
Even with this error message still works for the first file but it does not work with the second file. Can anybody help me to find the reason of this error message? Thank you very much in advance.
Function CallFunction(SheetName1 As Variant, SheetName2 As Variant) As Long
' This is a function used to retrieve column titles and place them as checkboxes in a listBox
Dim jTitles(200) As String
Dim sTitles(200) As String
Dim titless As Integer
Dim titlesj As Integer
Dim wks1 As Worksheet
Dim wks2 As Worksheet
Dim Item(200) As String
SPathName = Range("F18").Value
SFilename = Range("F19").Value
JPathName = Range("F22").Value
JFilename = Range("F23").Value
Workbooks.Open Filename:=SPathName & "\" & SFilename
Workbooks.Open Filename:=JPathName & "\" & JFilename
Set wks1 = ActiveWorkbook.Worksheets(SheetName1)
For j = 1 To 199
If Trim(wks1.Cells(4, j).Value) = "" Then
titlesj = j - 1
Exit For
End If
jTitles(j - 1) = wks1.Cells(4, j).Value
Next
j = 1
' Add column titles from files into the listbox as checkboxes
For j = 0 To titlesj
Sheet1.ListBox1.AddItem jTitles(j)
Sheet1.ListBox3.AddItem jTitles(j)
Next
Set wks2 = ActiveWorkbook.Worksheets(SheetName2) ' <=== HERE POPS THE ERROR MESSAGE
For s = 1 To 199
If Trim(wks2.Cells(1, s).Value) = "" Then
titless = s - 1
Exit For
End If
sTitles(s - 1) = wks2.Cells(1, j).Value
Next
s = 1
For s = 0 To titless
Sheet1.ListBox2.AddItem sTitles(s)
Sheet1.ListBox4.AddItem sTitles(s)
Next
Workbooks(JFilename).Close
' Workbooks(SFilename).Close
End Function
Subscript out of Range error arises in these circumstances when the specified sheetname does not exist in that workbooks Worksheets collection.
I notice you have two open workbooks specified by:
Workbooks.Open Filename:=SPathName & "\" & SFilename
Workbooks.Open Filename:=JPathName & "\" & JFilename
However, both of your worksheet assignments refer only to the ActiveWorkbook.
The cause of the error is certainly that SheetName2 does not exist in the ActiveWorkbok (which is specified by JFilename)
Especially when working with multiple books or worksheets, it is always preferable to avoid using Activate/Select methods-- otherwise you need to keep track of which workbook/worksheet/etc. is "Active", and that makes for spaghetti code and lots of unnecessary calls to the .Activate method.
I know that SheetName1 exists in JFilename, and I am assuming that SheetName2 exist in the workbook SFileName.
Instead, define two Workbook variables:
Dim wb1 as Workbook
Dim wb2 as Workbook
Assign the results of the Workbooks.Open method to these workbooks:
Set wb2 = Workbooks.Open(Filename:=SPathName & "\" & SFilename)
Set wb1 = Workbooks.Open(Filename:=JPathName & "\" & JFilename)
Now, wb1 is the "Active" workbook, so with the worksheet assignments:
Set wks1 = wb1.Worksheets(SheetName1)
And later for the Sheetname2:
Set wks2 = wb2.Worksheets(Sheetname2)
Otherwise, there is a typo in your worksheet names or the string parameters you're sending to this function. Doublecheck/debug that the value of SheetName2 is correct and that it exists.