This should be dead simple but i'm throwing a total blank so far, i've googled around and not found an answer either.
I'm creating a new workbook using VBA and i'd like to save that workbook so that it opens on the last row containing data when the user opens it. This is what i have so far:-
With ActiveWorkbook
'Added a last row selection so the sheet will open at the bottom of the page - Ash 07/04/14
LastRow = Range("A65536").End(xlUp).Select
Rows(ActiveCell.Row).Activate
.SaveAs str_DestFolder & str_File, FileFormat:=xlOpenXMLWorkbook, AccessMode:=xlShared
.Close
End With
Somehow this is failing me, any help would be much appreciated!
You could add the following line, after activating your last row:
ActiveWindow.ScrollRow = ActiveCell.Row
So your full code would be
With ActiveWorkbook
LastRow = Range("A65536").End(xlUp).Select
Rows(ActiveCell.Row).Activate
ActiveWindow.ScrollRow = ActiveCell.Row
.SaveAs str_DestFolder & str_File, FileFormat:=xlOpenXMLWorkbook, AccessMode:=xlShared
.Close
End With
Several suggestions
Code that should be run to set the workbook up for the next open should be run in the BeforeSave or Open Events.
best to run the code to work on a specific sheet automatically (the first sheet in the sample below) rather than rely on it being active.
Excell 2007 and onwards have 1 million rows, so either use Cells(Row.Count,"A").End(xlup) or Find rather than Range("A65536").End(xlup)`.
code for the ThisWorkbook module (runs automatically on save)
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet
Set ws = Sheets(1)
Dim rng1 As Range
Set rng1 = ws.Columns("A:A").Find("*", ws.[a1], xlValues, , xlByRows, xlPrevious)
Application.Goto rng1
ActiveWindow.ScrollRow = rng1.Row
End Sub
LastRow = Wb.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Wb.Worksheets("Sheet1").Cells(LastRow, 1).Select
With Wb
Application.DisplayAlerts = False
.SaveAs Filename:="YourFilePath", AccessMode:=xlShared
.Close
Application.DisplayAlerts = False
End With
Set Wb = Nothing
Try this...
Related
I have spent a lot of time here and elsewhere searching, and I haven't uncovered an answer. I have a spreadsheet created and used in Excel O365 I use to manage a backlog of testing to be done, and it also includes a tab to handle forecasting.
In two separate macros, the process of selecting a worksheet causes Excel to crash.
It behaves exactly as though the worksheets had been renamed in the file but not updated in the vba (an error I have previously made and learned the hard way) but nothing has been renamed, and as far as I can tell, nothing has changed at all for months. Yet, this started misbehaving about a week ago and I can't figure it out.
Example code that is failing:
Sub Send_Range_Or_Whole_Worksheet_with_MailEnvelope()
Dim AWorksheet As Worksheet
Dim Sendrng As Range
Dim rng As Range
'On Error GoTo StopMacro
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Fill in the Worksheet/range you want to mail
'Note: if you use one cell it will send the whole worksheet
Set Sendrng = ThisWorkbook.Sheets("Weekly Forecast").Range("A10:A78")
'Remember the activesheet
Set AWorksheet = ActiveSheet
With Sendrng
' Select the worksheet with the range you want to send
.Parent.Select
'Remember the ActiveCell on that worksheet
Set rng = ActiveCell
'Select the range you want to mail
.Select
' Create the mail and send it
ActiveWorkbook.EnvelopeVisible = True
With .Parent.MailEnvelope
' Set the optional introduction field thats adds
' some header text to the email body.
.Introduction = "See below for the weekly forecast. Thank you!"
With .Item
.To = "(redacted email address)"
.Subject = "Weekly Forecast"
.Send
End With
End With
'select the original ActiveCell
rng.Select
End With
'Activate the sheet that was active before you run the macro
AWorksheet.Select
StopMacro:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
ActiveWorkbook.EnvelopeVisible = False
End Sub
The "Set Sendrng = " statement is where Excel crashed when stepping through this macro.
Example 2 is a poor man's log of some data where it is simply copied from one worksheet and pasted into another for purpose of a 'snapshot':
Sub RefreshAllData()
' Updated 28Nov2017: Added "add to backlog log" ability
' RefreshAllData Macro
' Turn off screen updating
Application.ScreenUpdating = False
' Refresh all data / queries
ActiveWorkbook.RefreshAll
'Calculate should update all pivot tables
Calculate
' Append latest backlog to the backlog log
Sheets("2.7").Select
Range("A60:D73").Select
Selection.Copy
Sheets("Backlog Log").Select
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Sheets("2.7").Select
Range("A1").Select
' Resume screen updating
Application.ScreenUpdating = True
End Sub
The Sheets("2.7").Select statement is where Excel crashes.
Things I have tried:
You can see I've got one instance where the sheet select is direct, and one where it is a named range, and both fail.
I have attempted renaming of sheets and updating the code to reflect the new names, but those also fail.
I have reset macro security to force it to re-ask / re-enable macros, and this did not have an affect.
I'm at wit's end on this seemingly trivial issue, but these save enough manual time that I would really like to figure them out. Any help or pointers would be greatly appreciated.
You can try this for your first sub. Modify the MailMe range to your Forecast range.
Option Explicit
Sub ForeCast()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Weekly Forecast")
'Modify the below range to send
Dim MailMe As Range: Set MailMe = ws.Range("A10:A78")
Application.ScreenUpdating = False
With MailMe
ThisWorkbook.EnvelopeVisible = True
With MailEnvelope
.Introduction = "See below for the weekly forecast. Thank you!"
With .Item
.To = "(redacted email address)"
.Subject = "Weekly Forecast"
.Send
End With
End With
End With
ThisWorkbook.EnvelopeVisible = False
Application.ScreenUpdating = True
End Sub
If the code is housed in the book in that holds your sheets, the below should work. Notice that you never need .Select or .Selection to move/add/change/delete a cell/range/sheet/book.
Sub RefreshAllData()
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("2.7")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Backlog Log")
Application.ScreenUpdating = False
ThisWorkbook.RefreshAll
ws1.Range("A60:D73").Copy
ws2.Range("A" & ws2.Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValuesAndNumberFormats
Application.ScreenUpdating = True
End Sub
I'm trying to write a VBA code to copy "Non-Blank" cells from one file to another. This code selects the last Non Blank row, but for the column it's copying A4 to AU. I'd like to copy columns A4 to LastcolumnNotblank and also last row. So basically copy A4 to (LastColumn)(LastRow)Not Blank
Would be really grateful if someone can help by editing the below code. Many thanks.
Sub Export_Template()
'' TPD
File_name = Application.GetSaveAsFilename(InitialFileName:="Engineering TPD", FileFilter:="Excel Files (*.xlsx), *.xlsx")
If File_name <> False Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
For i = 4 To LastRow
If Left(ActiveSheet.Range("A" & i).Value, 1) <> "" Then lastactiverow = i
Next i
'MsgBox (lastactiverow)
ActiveSheet.Range("A4:AU" & lastactiverow).Select
Selection.Copy
Set NewBook = Workbooks.Add
ActiveSheet.Range("A1").PasteSpecial xlPasteValues
ActiveWorkbook.SaveAs Filename:=File_name, FileFormat:=51
ActiveWorkbook.Close (False)
End If
End Sub
The code below will preserve your ActiveSheet range and use SaveAs to save to a new workbook with your specific name, without all the extra crap. It deletes all the sheets except for the ActivSheet, and deletes the first three rows, then using SaveAs to save to ThisWorkbook.Path. Your macro enabled workbook will not be changed.
I actually don't like to use ActiveSheet due to the obvious problems, but since you were using it i kept it. I would suggest you use the name of the worksheet.
Sub SaveActiveSheetRangeAsNewWorkbook()
Dim ws As Worksheet
Application.DisplayAlerts = False
With ThisWorkbook
For Each ws In Application.ThisWorkbook.Worksheets
If ws.Name <> ActiveSheet.Name Then
ws.Delete
End If
Next
.Sheets(1).Range("A1:A3").EntireRow.Delete
.SaveAs Filename:="Engineering TPD", FileFormat:=xlOpenXMLWorkbook
End With
Application.DisplayAlerts = True
End Sub
I'm assuming that Col A is a good indicator of where to find your last used row
Also assuming that Row 1 is a good indicator of where to find your last used column
You need to change Sheet1 on 3rd line of code to the name of your sheet that has the data to be copied
You need to declare variables (Use Option Explicit)
Avoid .Select and .Selection at all costs (none are found in below solution)
You did not re-enable ScreenUpdating and DisplayAlerts
This is tested and works A-OK
Option Explicit
Sub Export_Template()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim NewBook As Workbook
Dim LRow As Long, LCol As Long
Dim FileName
FileName = Application.GetSaveAsFilename(InitialFileName:="Engineering TPD", FileFilter:="Excel Files (*.xlsx), *.xlsx")
If FileName <> False Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set NewBook = Workbooks.Add
LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
LCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
ws.Range(ws.Cells(4, 1), ws.Cells(LRow, LCol)).Copy
NewBook.Sheets(1).Range("A1").PasteSpecial xlPasteValues
NewBook.SaveAs FileName:=FileName, FileFormat:=51
NewBook.Close False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End If
End Sub
I recently asked a question and received a great answer on this site, but I am now running into a different problem. The code below works well for running through each workbook in a folder, copying a sheet's contents, and pasting those contents into a master workbook exactly how I would like:
Sub ConslidateWorkbooks()
'Code to pull sheets from multiple Excel files in one file directory
'into master "Consolidation" sheet.
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Dim wbName As String
With ActiveSheet
Range("A1").Activate
End With
Application.ScreenUpdating = False
FolderPath = ActiveWorkbook.Path & "\"
Filename = Dir(FolderPath & "*.xls*")
wbName = ActiveWorkbook.Name
Do While Filename <> ""
If Filename <> wbName Then
Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
copyOrRefreshSheet ThisWorkbook, Sheet
Next Sheet
Workbooks(Filename).Saved = True
Workbooks(Filename).Close
ActiveSheet.Range("A1").Activate
End If
Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Sub copyOrRefreshSheet(destWb As Workbook, sourceWs As Worksheet)
Dim ws As Worksheet
On Error Resume Next
Set ws = destWb.Worksheets(sourceWs.Name)
On Error GoTo 0
If ws Is Nothing Then
sourceWs.Copy After:=destWb.Worksheets(destWb.Worksheets.Count)
Else
ws.Unprotect Password:="abc123"
ws.Cells.ClearContents
sourceWs.UsedRange.Copy
ws.Range(sourceWs.UsedRange.Address).PasteSpecial (xlPasteAll)
Application.CutCopyMode = False
End If
End Sub
The problem I am having now: After the paste is completed, each sheet in the master workbook has all of its cells selected, as though I Ctrl+A'd the entire sheet. I would like to get rid of this. It is a small task which I tried to accomplish in the line ActiveSheet.Range("A1").Activate within the Do While .. loop, but it has not worked for me.
EDIT:
I found a solution that works in this case. I am not sure why this was necessary, because the comments and answers in this thread seem like they should work, but they did not. I call this sub before I turn screenupdating to True in the main sub:
Sub selectA1()
Worksheets(1).Activate
Dim Sheet As Worksheet
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Activate
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
Sheet.Range("A1").Select
Next Sheet
Worksheets(1).Activate
End Sub
I realize this is more complicated than it should be, but it works for my purposes.
In your copy sub, add in another code in the loop that will select a cell which should deactivate the total used range selection and just select the coded range.
Sub copyOrRefreshSheet(destWb As Workbook, sourceWs As Worksheet)
Dim ws As Worksheet
On Error Resume Next
Set ws = destWb.Worksheets(sourceWs.Name)
On Error GoTo 0
If ws Is Nothing Then
sourceWs.Copy After:=destWb.Worksheets(destWb.Worksheets.Count)
Else
ws.Unprotect Password:="abc123"
ws.Cells.ClearContents
sourceWs.UsedRange.Copy
ws.Range(sourceWs.UsedRange.Address).PasteSpecial (xlPasteAll)
ws.range("A1").select
Application.CutCopyMode = False
End If
End Sub
I added ws.range("A1").select which should do as I described above.
I'm currently looking for a code to improve my Dashboard. Actually, I need to know how to simplify and make my code more efficient. It's working but It's longer and longer day after day because of the amount of data/traffic at certain hours on the company network.
I know it's not correct to use "Select" but I didn't find an answer to my problem.
Situation:
I created my layout on SAP, and I export them (default file name is
'Export.xls')
I go to my Main Excel File (called 'Dashboard') and I
run the code from the WS concerned by the layout exported
The username need to be captured in case I'm out of office, and someone else need to run the code.
When Data are imported from SAP Export to my main file, it closes the SAP "Export" file
This is my current code:
Sub PasteSAP()
'
' Pull Data From SAP Export - Excel File
'
Dim UserName As String
UserName = Environ("username")
'Clear "PasteSAP" sheet in case the next one will have less data
Range("A:O").Select
Selection.ClearContents
'Open SAP Excel file (the export)
Workbooks.Open "C:\Users\" & UserName & "\Desktop\export.XLSX"
Windows("export.XLSX").Activate
'Copy data of the SAP Excel file
Range("A:O").Select
Selection.Copy
'Go back to the main file and paste in the active worksheet
Windows("Dashboard - 2017.xlsm").Activate
Range("A:O").Select
ActiveSheet.Paste
'Close SAP Excel file
Windows("export.XLSX").Activate
Application.DisplayAlerts = False
ActiveWindow.Close
'Change Format
Range("A:A").Select 'specify the range which suits your purpose
With Selection
Selection.NumberFormat = "General"
.Value = .Value
End With
Dim wks As Worksheet
Dim lastRow As Long
Dim r As Long
Set wks = ActiveSheet
lastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
For r = 2 To lastRow
If wks.Cells(r, 1) <> "" Then
wks.Cells(r, 7).NumberFormat = "General"
wks.Cells(r, 9).Style = "Currency"
End If
Next r
Range("A1").Select
End Sub
Since you are copying the whole columns you do not Need to erase them beforehand.
Usually you would not want to jump between windows since it takes lots of time.
Also turning off ScreenUpdating could speed things up.
Try the following code:
...
Application.ScreenUpdating = False
dim wb_export as Workbook
dim ws_export_from as Worksheet, ws_export_to as Worksheet
Set wb_export = Workbooks.open("...\Export.xls")
Set ws_export_from = wb_export.Worksheets("your worksheet")
Set ws_export_to = Worksheets("Destination worksheet")
ws_export_from.range("A:O").Copy Destination := ws_export_to.Range("A:O")
wb_export.close false
set wb_export = Nothing
set ws_export_from = Nothing
set ws_export_to = Nothing
Application.ScreenUpdating = True
This should run a lot faster.
I am using the following function to save a worksheet from a workbook and save it to a separate workbook. However, it is saving the formulas, whereas I would rather just the values end up in the final workbook. How can I modify this so the resultant workbook doesn't contain formulae and just values?
Sub Sheet_SaveAs(FilePath As String, SheetToSave As Worksheet)
Dim wb As Workbook
Set wb = Workbooks.Add(xlWBATWorksheet)
With wb
SheetToSave.Copy After:=.Worksheets(.Worksheets.Count)
Application.DisplayAlerts = False
.Worksheets(1).Delete
Application.DisplayAlerts = True
.SaveAs FilePath
.Close False
End With
End Sub
Using the link kindly provided I tried this, but to no avail:
Sub Sheet_SaveAs(FilePath As String, SheetToSave As Worksheet)
Dim wb As Workbook
Set wb = Workbooks.Add(xlWBATWorksheet)
With wb
SheetToSave.Copy After:=.Worksheets(.Worksheets.Count)
Application.DisplayAlerts = False
.Worksheets(1).Delete
.Worksheets(1).Copy
.Worksheets(1).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.DisplayAlerts = True
.SaveAs FilePath
.Close False
End With
End Sub
but I get an error on the pastespecial line??
.Worksheets(1).Copy
This copies the sheet itself and does not relate to PasteSpecial. You could use:
.Worksheets(1).UsedRange.Copy
or similar. For example, Worksheets(1).Cells.Copy.
I assume it should be Worksheets(.Worksheets.Count) though.
In the following I am using SpecialCells to identify only the formulas in the worksheet, and setting rng.Value = rng.Value to convert these to the results of the formulas.
Sub Sheet_SaveAs(FilePath As String, SheetToSave As Worksheet)
Dim wb As Workbook
Dim ws As Worksheet
Dim rngFormulas As Range, rng As Range
Set wb = Workbooks.Add(xlWBATWorksheet)
With wb
SheetToSave.Copy After:=.Worksheets(.Worksheets.Count)
Set ws = .Worksheets(.Worksheets.Count)
Application.DisplayAlerts = False
.Worksheets(1).Delete
Application.DisplayAlerts = True
With ws
Set rngFormulas = ws.Cells.SpecialCells(xlCellTypeFormulas)
For Each rng In rngFormulas
rng.Value = rng.Value
Next rng
End With
.SaveAs FilePath
.Close False
End With
End Sub
You will need to add some error handling code, to handle the case where there are no formulas in the copied worksheet. (Array formulas may also need to be accounted for.)
The easiest way to copy the values is to do it in 2 steps:
Copy the sheet, then replace the formulas with their values
After:
.Worksheets(1).Delete
in your original code, add the lines:
With Range(Worksheets(.Worksheets.Count).UsedRange.Address)
.Value = .Value
End With
The .value=.value is telling excel to replace every value with the value that is currently being displayed, so all formulas will be replaced with their calculated value
Sorry, answer was starting to look a complete mess, so deleted it and started again. I've written this - it appears to work fine when I tested it - you just need an extra line to save any resulting spreadsheet. :)
For Each Cell In ActiveSheet.UsedRange.Cells
Cell.Copy
Cell.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next