I've created a spreadsheet for tracking student data for my wife. There are 2 versions, the master and the teacher version. The only difference is that the teacher version has a couple of tabs and buttons hidden.
At the end of every day she gathers the teacher versions and merges their data into the master version using a macro attached to a button. On a regular basis it causes Excel to crash. It seems like trying to merge a workbook that is on a usb stick is a surefire way to make it crash, but there are other circumstances that I haven't identified yet.
She isn't technical enough to step through the code until it blows and I can't be there when she is doing it.
Previous attempts to harden the code involved getting rid of any instance of Activesheet or Activeworkbook, and always using a direct reference to the worksheet (ie Sheet1, but renamed to something meaningful - "merge" in the example below).
The function below, LoadTeacherData, is called once for each workbook to merge. All it does is copy the existing records on the teacher's data tab, copy them to the master merge tab and then delete them from the source. When it crashes it is immediately after selecting the file to load, I think.
Sub LoadTeacherData()
Dim wb_td As Workbook
Dim td As Worksheet
Dim newdata As Range
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Excel files", "*.xlsm"
If .Show = -1 Then
file_name = .SelectedItems(1)
Else
Exit Sub
End If
End With
Application.ScreenUpdating = False
Set wb_td = Workbooks.Open(Filename:=file_name, UpdateLinks:=False, ReadOnly:=False)
If wb_td Is Nothing Then
MsgBox "Unable to open file, check path", vbOKOnly
Exit Sub
End If
file_name = wb_td.Name
Set td = wb_td.Worksheets("data")
row = LastRow(td, "C")
col = LastCol(td, 1)
Set newdata = td.Range("a2", td.Cells(row, col))
newdata.Copy Destination:=Merge.Cells(LastRow(Merge, "C") + 1, 1)
newdata.Clear
MsgBox (row - 1 & " records merged")
wb_td.Close
ThisWorkbook.Activate
ThisWorkbook.Save
Application.ScreenUpdating = True
End Sub
Function LastRow(ByRef ws As Worksheet, ByVal colname As String)
LastRow = ws.Range(colname & ws.Rows.Count).End(xlUp).row
End Function
Function LastCol(ByRef ws As Worksheet, ByVal rownum As Long)
LastCol = ws.Cells(rownum, ws.Columns.Count).End(xlToLeft).Column
End Function
My suspicion is that it has something to do with permissions when opening the file. Her excel version is configured so that she has to enable content every time when opening a file.
You may be dealing with a corrupted file. Look at the workbooks.open method. There are a few options under corruptload that may help. Try this one and experiment to see if any of the others work better in your situation.
Set wb_td = Workbooks.Open(Filename:=file_name, UpdateLinks:=False, ReadOnly:=False, corruptload:=xlRepairFile)
Related
I've encountered a strange thing: I've joined three workbooks: Personal Data Tracker, Global Tracker and the workbook with pivots and charts. The logic is as it follows: the user clicks on a button after the work is finished so the data is copied to the GL Tracker. Once the change event is triggered in the GL Tracker Table, the last workbook opens, the pivot is refreshed upon the open vent and the wb is closed.
Everything seems to be working fine, however when I run the macro live, at the very end I get an error message about
"Application-defined or object-defined error".
Only OK and Help button displayed, it doesn't make the VBE Open so I could debug it.
Would anyone know what it may be happening even if the whole chain works fine?
Thank you.
Code from the Personal Tracker:
Sub test()
Dim path As String
Dim wb As Workbook
path = ThisWorkbook.path & "\Dest.xlsm"
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Total").Range("R1").Value = Date
Range("R1").Font.Color = VBA.ColorConstants.vbWhite
Worksheets("TOTAL").Range("B2:B13").Copy
On Error GoTo Handler
Workbooks.Open (path)
On Error GoTo 0
Set wb = Workbooks("Dest")
Worksheets("Sheet1").Range("B2").PasteSpecial Paste:=xlPasteValues
Exit Sub
Handler:
MsgBox "Someone else is saving their data at the moment." & vbNewLine & _
"Please try in a few seconds"
End Sub
Code from the GL Tracker:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MRange As Range
Dim wbPivot As Workbook
Dim pt As PivotTable
Dim ws As Worksheet
Dim Name As String
Dim answer As VbMsgBoxResult
Set MRange = ThisWorkbook.Sheets(1).Range("Table1")
Name = Application.UserName
Application.ScreenUpdating = False
If Not Intersect(Target, MRange) Is Nothing Then
Application.EnableEvents = True
Set wbPivot = Workbooks.Open("C:\Users\jakub\Desktop\Excel - various\Pivot.xlsm")
End If
'refresh
For Each ws In wbPivot.Worksheets
For Each pt In ws.PivotTables
pt.PivotCache.Refresh
pt.Update
pt.RefreshTable
Next
Next
'saving
Application.ScreenUpdating = True
If Application.UserName <> "Jakub Tracz" Then
MsgBox "User not authorised. Workbook will be closed."
wbPivot.Close True
ThisWorkbook.Close True
Else
answer = MsgBox(Prompt:="Do you want to save and close the workbook?", _
Buttons:=vbYesNo + vbQuestion)
Select Case answer
Case vbYes
wbPivot.Close True
ThisWorkbook.Close True
Case vbNo
MsgBox "Welcome, " & Application.UserName
End Select
End If
End Sub
I'm going to give you a proof of concept code as an example for you to use. This will not exactly answer your question with code you can just copy/paste, but you will be able to use this to put it together the way you want it to work instead of me making assumptions about many things and restructuring it myself.
This simply demonstrates how to use a workbook object variable in one routine that can reference another workbook, and how to make changes to that 2nd workbook and save/close it.
Sub Tracker_Update()
Dim wbPivot as Workbook
' open the workbook
Set wbPivot = Workbooks.Open("C:\Users\jakub\Desktop\Excel - various\Test.xlsx")
' optionally make it hidden
wbPivot.Visible = False
With wbPivot
' pretend this code updates the pivot table
.Worksheets(1).Range("A1") = "hello world"
' Close and save it
.Close True
End With
' optionally clear the variable
' this is not really needed in VBA, but if you eventually
' start using VB.NET with Excel as a COM object,
' you will want to know how to do this part when you are done
Set wbPivot = Nothing
End Sub
I think you will like this approach in the end much better in the end anyway, as the code isn't scattered around so much in different places. Easier to debug later, and easier for someone else to understand what you are doing if and when you leave the company.
I'm still reasonably new to VBA and feel I'm punching a little above my weight, so hopefully someone can help.
I need to issue a spreadsheet to people in my company which they can fill out and send it back. This needs to be done multiple times, so I have tried to automate this as much as possible. The source data is pasted in an "input" tab - this is then pivoted by user and input into a template tab. I can select any user and run a macro which does this and exports the filled out template to a new workbook.
In this template tab, I have dependent drop-down lists, which I have done by data validation - this relies on named ranges from the "coding" tab, which is also exported. One named range shows a list of values, and the other indexes over this and matches it to the required cell, to ensure only valid combinations are shown.
My issue is that the new workbook must not contain any links to the master - it should function completely in its own right. However, something is going wrong with the data validation/named ranges. Either some named ranges are being deleted (I know which bit of code is doing that but without it you get prompted to update links) or the data validation formula links back to the original workbook and doesn't work. I cannot find another way of achieving what I need without this particular data validation set up, so I need to try and adjust my macro to cater for this.
Is it possible to simply copy the template and coding tabs, with all the data validation, to a new workbook and break all links to the original, so that there are no startup prompts and the drop-downs all work?
Sub Copy_To_New_Workbook()
Dim wb As Workbook
Dim name As String
Dim ExternalLinks As Variant
Dim x As Long
Dim strFolder As String, strTempfile As String
name = Worksheets("Control").Cells(14, 7).Value
Let FileNameIs = Range("Filepath").Value & Range("FileName").Value
Set wb = Workbooks.Add
ThisWorkbook.Worksheets("Coding").Copy Before:=wb.Sheets(1)
ActiveSheet.name = "Coding"
ThisWorkbook.Worksheets("Transactions").Copy Before:=Worksheets("Coding")
ActiveSheet.name = "Transactions"
With ActiveSheet.UsedRange
.Value = .Value
End With
Application.DisplayAlerts = False
Worksheets("Sheet1").Delete
Application.DisplayAlerts = True
ExternalLinks = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
ExternalLinks = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
For x = 1 To UBound(ExternalLinks)
wb.BreakLink name:=ExternalLinks(x), Type:=xlLinkTypeExcelLinks
Next x
Dim objDefinedName As Object
For Each objDefinedName In wb.Names
If InStr(objDefinedName.RefersTo, "[") > 0 Then
objDefinedName.Delete
End If
Next objDefinedName
On Error GoTo 0
wb.SaveAs Filename:=FileNameIs, FileFormat:=52
ActiveWorkbook.Close
End Sub
(Beginner VBA coder here!)
Does anyone know how to extract multiple, specific cell data from multiple closed workbooks that have the same worksheet format?
I am currently tasked to copy very specific data from certain cells from many different and new (but same format) sources and transfer them into another group of specific cells in an existing masterlist with different worksheets.
This is the code I wished would help, but it is lacking in too many ways as compared to what I need...
Sub Importsheet()
Dim Importsheet As Worksheet
'import worksheet from a closed workbook
Sheets.Add Type:= _
'e.g. directory below
"C:\Users\Loli\Desktop\Testing1.xlsx"
End Sub
This code helps me get the sheets out of the closed source workbook but not the specifically placed cells in the closed source excel. It also can't paste the data in specifically placed cells in different sheets in the destination excel.
It is very difficult to completely understand your requirements as it seems like sometimes you want to copy a range and some other times a single cell, so to point you in the right direction my answer only shows how to open and copy the relevant Sheet into your master workbook to then be able to reference the cell/ranges you want
(I would once you get your data then delete the Worksheet, so that your master doesn't suddenly becomes massive in size):
Sub ImportSheet()
Dim sImportFile As String, sFile As String
Dim sThisBk As Workbook
Dim vfilename As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sThisBk = ActiveWorkbook
sImportFile = Application.GetOpenFilename( _
FileFilter:="Microsoft Excel Workbooks, *.xls; *.xlsx", Title:="Open Workbook") 'open dialog to choose the file you want, you can change this to loop through a folder if they are all in there.
If sImportFile = "False" Then 'check if a file was selected before importing
MsgBox "No File Selected!"
Exit Sub
Else
vfilename = Split(sImportFile, "\")
sFile = vfilename(UBound(vfilename))
Application.Workbooks.Open Filename:=sImportFile 'open the selected file
Set wbBk = Workbooks(sFile)
With wbBk
If SheetExists("Raw_Data") Then ' you should change this to the date, you can do this easily by using a variable such as if SheetExists(variableDate) then, where variableDate = "12/12/2017" or something similar
Set wsSht = .Sheets("Raw_Data")
wsSht.Copy before:=sThisBk.Sheets("Sheet1") 'copy the worksheet into your master
'WsSht.range("A1:B2").copy Destination:=sThisBk.Sheets("Temp").Range("A1").paste xlpastevalues 'use this to copy a specified range in this case A1:B2 to a sheet in master workbook called Temp A1
Else
MsgBox "There is no sheet with name :Raw_Data in:" & vbCr & .Name
End If
wbBk.Close SaveChanges:=False
End With
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Function SheetExists(sWSName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(sWSName)
If Not ws Is Nothing Then SheetExists = True
End Function
I have a pivot table in excel which looks like this:
Team Doc 1 Doc 2 Grand Total
Team A 13 12 25
Team B 8 7 15
Team C 32 5 37
Grand Total 53 24 77
I have already written a piece of VBA which will format any drill down sheets for printing (Workbook_NewSheet(ByVal Sh As Object)). However, as I'm trying to make this as user friendly as possible, I'd really like to be able to use vba to automatically rename any worksheets generated from the pivot table. However, I'm not sure how to do it as the content of each worksheet will be different depending on where the user clicks (i.e. if the user clicks in Team A Doc 1 Total then the sheet should be named 'Team A Doc 1' but if the user clicks in Grand Total row of Doc 2 then the sheet should be named 'Grand Total Doc 2') - I think there are something like 15 different worksheet names that could occur which is why I'm guessing the worksheet defaults to Sheet1! I'm thinking that a name could be generated by using offset to pick up the team name or the column name based on the active cell but I'm not really sure where to start so any suggestions/assistance would be greatly appreciated!
Thanks
I wish I could comment, but I can't yet, as I have not enough rep points! (Had to restart my account!)
I can suggest that you record a macro while you do a drill down on any given data point manually, and see how the recorded vba code looks. I would think from there you can configure your code to base the name of your worksheet on some element of the recorded code.
Since, I wanted this to be a comment, I will delete this if it's not helpful.
Update To Your Newly Posted Answer:
To check if the sheet already exists when a user drills down, you can check if the sheet existss after you get the sheet name to and if it does, select it, rather than creating a new one. Otherwise, you create it.
See this code for that:
Private Sub Workbook_NewSheet(ByVal sh As Object)
Application.ScreenUpdating = False
Dim shtCur As Worksheet
Set shtCur = ActiveSheet
Sheets("DQ Summary").Select
RN = ActiveCell.Row
CN = ActiveCell.Column
SheetName = Cells(RN, 2).Value & " - " & Cells(9, CN).Value
If SheetExists(SheetName) Then
Worksheets(SheetName).Select
Else
shtCur.Move _
After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
shtCur.Name = "SheetName"
End If
Application.ScreenUpdating = True
End Sub
Function SheetExists(wsName As String, Optional wb As Workbook = Nothing) As Boolean
SheetExists = False
Dim WS As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set WS = wb.Worksheets(wsName)
On Error GoTo 0
If Not WS Is Nothing Then SheetExists = True
End Function
I've managed to come up with something fairly workable:
Private Sub Workbook_NewSheet(ByVal sh As Object)
Dim RN, CN As Byte
Dim SheetName As String
Application.ScreenUpdating = False
ActiveSheet.Move _
After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
'Names the sheet according to the pivot drill
Sheets("DQ Summary").Select
RN = ActiveCell.Row
CN = ActiveCell.Column
SheetName = Cells(RN, 2).Value & " - " & Cells(9, CN).Value
'Identifies if worksheet already exists and replaces it if so.
Application.DisplayAlerts = False
On Error Resume Next
mySheetNameTest = Worksheets(SheetName).Name
If Err.Number = 0 Then
Worksheets(SheetName).Delete
MsgBox "The sheet named ''" & SheetName & "'' already exists but will be replaced."
Else
Err.Clear
End If
Application.DisplayAlerts = True
Sheets(ActiveWorkbook.Sheets.Count).Select
ActiveSheet.Name = SheetName
End Sub
Basically it's added onto the newsheet event - the macro adds the new sheet to the end of the workbook, goes to the pivot table sheet and identifies the column and row names of the active cell (since the column name and row name will always be static I can hard code this in) and then locates the newly added sheet (always at the end of the workbook) and renames it. Unfortunately there's an issue if a user tries to drill on the same data twice (can't have two worksheets with the same name) which I'm hoping to iron out.
Thanks for views/comments.
Edit: Updated code to work around worksheet duplication issue, seems to be doing the trick!
I have an excel sheet which has some huge data. Data is organized as follows,
A set of 7 columns and n rows; as in a table, and 1000s of such tables are placed horizontally with an empty column to separate. A screenshot is below..
...
I just want to have data of every 'table' saved into a different file. Manually it would take ever! So, Is there a macro or something I would automate this task with.
I am not well versed with writing macros or any VBA stuff.
Thanks,
Tony has a valid point when he says
If the table starting at C1 finishes on row 21, does the next table start at C23? If the table starting at K1 finishes on row 15, does the next table start at K17 or K23?
So here is a code which will work in any condition i.e data is set horizontally or vertically.
DATA SNAPSHOT
CODE
'~~> Change this to the relevant Output folder
Const FilePath As String = "C:\Temp\"
Dim FileNumb As Long
Sub Sample()
Dim Rng As Range
Dim AddrToCopy() As String
Dim i As Long
On Error GoTo Whoa
Application.ScreenUpdating = False
Set Rng = ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)
If Not Rng Is Nothing Then
AddrToCopy = Split(Rng.Address, ",")
FileNumb = 1
For i = LBound(AddrToCopy) To UBound(AddrToCopy)
ExportToSheet (AddrToCopy(i))
Next i
End If
MsgBox "Export Done Successfully"
LetsContinue:
Application.ScreenUpdating = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
Sub ExportToSheet(rngAddr As String)
Range(rngAddr).Copy
Workbooks.Add
ActiveSheet.Paste
ActiveWorkbook.SaveAs Filename:= _
FilePath & "Output" & FileNumb & ".csv" _
, FileFormat:=xlCSV, CreateBackup:=False
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
FileNumb = FileNumb + 1
End Sub
NOTE: The above code will work for cells with only Text Values. For cells with only Numeric Values you have to use
Set Rng = ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, xlNumbers)
And for AlphaNumeric Values (As in your question above), use this
Set Rng = ActiveSheet.Cells.SpecialCells(xlCellTypeConstants)
HTH
Sid
As long as there is a blank row and a blank column around any datasets, this will use the AREAS() method to put them all in separate workbooks.
As per the prior example, it saves as CSV, but of course you can save it as you wish.
Option Explicit
Sub ExportDataGroups()
Dim fPATH As String, Grp As Long, DataRNG As Range
fPATH = "C:\Path\Where\I\Want\My\Files\Saved\" 'remember the final \
Application.ScreenUpdating = False
Set DataRNG = ActiveSheet.UsedRange
For Grp = 1 To DataRNG.Areas.Count
DataRNG.Areas(Grp).Copy
Sheets.Add
Range("A1").PasteSpecial
ActiveSheet.Move
ActiveWorkbook.SaveAs Filename:=fPATH & "-" & Format(Grp, "0000") & ".csv", _
FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Next Grp
MsgBox "A total of " & Grp & " files were created"
Application.ScreenUpdating = True
End Sub
In your response to my comment you state: "File name, I never thought about it. Could be anything for now." From bitter experience I can tell you that dealing with thousands of files with system generated names is a nightmare. You need to fix the name problem now.
I am also nervous about AddrToCopy = Split(Rng.Address, ","). Rng.Address will be of the form: "$C$1:$I$16, $K$1:$Q$16, $S$1:$Y$16, $C18$I$33, $K$18:$Q$33, $S$18:$Y$33, ...". If you search the internet you will find sites that tell you that Rng.Address has a maximum length of 253 characters. I do not believe this is correct. In my experience, Rng.Address is truncated at a complete sub-range. My experimentation was with Excel 2003 but I have found noting on the internet to suggest this limitation has been fixed in later versions of Excel. You much check Rng.Address with your version of Excel! I am not familar with Jerry Beaucaire, although he offers an interesting solution. Sid Rout always produces excellent code. If there is a problem, I am sure they will be able to fix it.
However, the real purpose of this "answer" is to say I would split this problem into three. This has lots of advantages and no disadvantages of which I am aware.
Step 1. Create a new worksheet, TableSpec, with the following columns:
A Worksheet name. (If tables are spread over more than worksheet)
B Range. For example: C1:I16, K1:Q16
C - I Headings from table. For example, AAPL, Open, High, Low, Close, Volume, AdjClose
Step 2. Check worksheet TableSpec; for example, are all table listed? Think about the file name and add column H to contain it. I read one of your comments to mean you would "AAPL" as the filename for the first table in which case you could set H2 to "=C2". Is "AAPL" unique? You could had a sequence number. There are lots of choices which you can think about before you generate any files.
Step 3. Worksheet TableSpec now gives all the information necessary to generate your files. You could delete most of the contents and test the file creation code on a couple rows.
I hope you can see advantages of this stepped approach, partcularly if your VBA is weak. Best of luck.