My team and I have an excel file where I use columns A to L. We use this file to send out different budgets and therefore have multiple versions of the file. What happens is that people start to adjust the column widths and afterwards the print area no longer fits.
We want to ensure a standardized layout version at all times.
I have set up a VBA that ensures that the pre-selected column widths are implemented upon opening the file. If somebody changes the width, this will automatically be adjusted when somebody else opens the file again.
The code I have works fine however, one problem is that it takes to long to run 2min30sec. Any suggestions on how to speed it up?
Sub Workbook_Open()
'-----START TIMER-----
Dim StartTime As Double
Dim TimeTaken As String
Dim ws As Worksheet
StartTime = Timer
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
Application.StatusBar = False
On Error Resume Next
'For Each ws In ActiveWorkbook.Worksheets ' Start of the VBA loop
For Each ws In Worksheets ' Start of the VBA loop
With ws
ws.Activate 'this part ensures each seperate tab is activated and the below code is run through
Columns("A").ColumnWidth = 0.94 'this line determines the column width
Columns("B").ColumnWidth = 6.56 'this line determines the column width
Columns("C").ColumnWidth = 13.56
Columns("D").ColumnWidth = 13.56
Columns("E").ColumnWidth = 13.56
Columns("F").ColxumnWidth = 10.11
Columns("G").ColumnWidth = 6.11
Columns("H").ColumnWidth = 10.11
Columns("I").ColumnWidth = 10.11
Columns("J").ColumnWidth = 13.56
Columns("K").ColumnWidth = 6.56
Columns("L").ColumnWidth = 6.56
Wsh.Range("A1").Select 'this part ensure each worksheet view start position is A1
ActiveWindow.View = xlPageBreakPreview 'Set Activesheet to Page Break Preview Mode
ActiveWindow.Zoom = 114 'this line sets the permanent zoom % for all tabs
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
End With
Next ws
Application.Goto ThisWorkbook.Sheets("resume").Range("A1"), True 'starting position upon opening the file
'Worksheets(1).Activate 'this line make sure view is at first tab
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
ActiveWindow.View = xlNormalView
'------ END TIMER------
TimeTaken = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Running time was " & TimeTaken & " (hours, minutes, seconds)"
End Sub
Related
This is a code that should copy from one open workbook (WorkbookA) to the other open one (WorkbookB):
Option Explicit
Dim shRange1 As String
Dim shRange2 As String
Dim shRange3 As String
Dim wrk As Workbook
Dim inx As Integer
Public Sub cPasteToWorkbookB()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
ActiveWindow.View = xlNormalView
For inx = 2 To 6
chooseInx
ThisWorkbook.Worksheets(inx).Range(shRange1).Copy
findOpenWorkbookB
ActiveWorkbook.Worksheets(inx).Range(shRange1).PasteSpecial Paste:=xlPasteValues
ThisWorkbook.Worksheets(inx).Range(shRange2).Copy
findOpenWorkbookB
pasteShRange3
Next inx
Set wrk = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
Application.StatusBar = False
End Sub
It has the following function for the cases, which are ranges in different worksheets:
Function chooseInx()
Select Case inx
Case 2:
shRange1 = "C6:S17"
shRange2 = "K24:L27"
shRange3 = "C24"
Case 3:
shRange1 = "C6:W14"
shRange2 = "K21:L23"
shRange3 = "C21"
Case 4:
shRange1 = "C6:S14"
shRange2 = "K21:L23"
shRange3 = "C21"
Case 5:
shRange1 = "C6:S14"
shRange2 = "K21:L23"
shRange3 = "C21"
Case 6:
shRange1 = "C6:U14"
shRange2 = "K21:L23"
shRange3 = "C21"
End Select
End Function
The code does it's job, but for this part:
Case 5:
shRange1 = "C6:S14"
the macro seem to change any values to 0 only in range "P6:P14" (it's not a typo) and then pastes the 0s to WorkbookB. This does not happen when I go through the macro with F8 - then I have the values as they were initially in both workbooks. And for Case 4 it works flawlessly, despite the ranges are exactly the same.
Here is the function for browsing all the open workbooks in search for WorkbookB:
Function findOpenWorkbookB()
For Each wrk In Workbooks
If InStr(wrk.Name, "WorkbookB") > 0 Then
wrk.Worksheets(inx).Activate
Exit For
End If
Next
End Function
Why such result? Why it overwrites the a part that was supposed to be copied only? I struggle to understand what is happening in the process, so I might not be as communicative with this post as I want to be. Any remarks are welcomed, I will adjust the question accordingly.
I tried to slow the macro a bit on different steps (copying, pasting and in the findOpenWorkbookB function), but to no avail.
For your reference below is the shRange1, from Case 5 with affected column P, with sensitive data hidden:
In greyed cells to the right are formulas, the ones from colums Q and R simply sum some cells on the same row from the left, the right extreme one is visible on the screen. None of the formulas refer to column P, the problematic one.
You most likely have formulas that evaluate to 0 or "" in range P6:P14. Either delete the formulas or copy the formatting by changing Paste:=xlPasteValues to Paste:=xlPasteValuesAndNumberFormats.
I am trying to set-up an Excel sheet with about 3000 rows, to print nicely to a PDF file.
I am trying to set-up the page to fit 1 page width, and I want to modify the Horizontal Page breaks according to row numbers stored in an array PgBreakRowsArr.
After I run the attached sub-routine, the page breaks are set-up nicely, but the printing width has shrunk from ~85% to ~45%, and printing at about 50% of the page size.
Any ideas ?
Code
Option Explicit
Sub SetFriendlyPrintArea(Sht As Worksheet)
'======================================================================================================================
' Description : Sub sets the Friendly Print Area.
' It loop through 'PgBreakRowsArr' array, and per rows stored inside sets the page breaks.
'
' Argument(s) : sht As Worksheet
'
' Caller(s) : Sub RawDataToByTimeReport (Excel_to_byTime_Report Module)
'======================================================================================================================
Dim LastRow As Long, i As Long
Dim VerticalPageCount As Long, HPageBreakIndex As Long
HPageBreakIndex = 1 ' reset pg. break index
Application.ScreenUpdating = False
With Sht
.Activate
LastRow = FindLastRow(Sht)
With .PageSetup
.PrintArea = "$A$1:I" & LastRow
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
' .PaperSize = xlPaperLetter
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = UBound(PgBreakRowsArr) + 1
End With
ActiveWindow.View = xlPageBreakPreview ' switch to Page Break view to set page breaks
' Debug.Print .HPageBreaks.Count
' loop through array and create Page Breaks according to array's rows
For i = 1 To UBound(PgBreakRowsArr) - 1
Set .HPageBreaks(i).Location = Range("A" & PgBreakRowsArr(i))
Next i
' --- last one need to add it (not move existing one) ---
.HPageBreaks.Add Before:=Range("A" & PgBreakRowsArr(i))
ActiveWindow.View = xlNormalView ' go back to normal view
End With
Application.ScreenUpdating = True
End Sub
.HPageBreaks is a nightmare. I pulled my hair out many times on it. Here you are a few magical things that make no harm and may help:
Issue .ResetAllPageBreaks before setting anything
Turn Application.PrintCommunication = False before and ... True after. It can improve the result, and also can speed up the operation. It depends on your printer and the printer driver.
Move the activecell out of the affected area and restore it (if necessary) after setting page breaks, like
somestring = Activecell.Address
Cells(4000, 3000).Activate
....
Range(somestring).Activate
If the amount of pages on the actual sheet and the size of the arrangement required for page division are different, the phenomenon of enlargement and reduction occurs. If the size of the array is smaller than the actual page amount, it will shrink, so it would be better to delete this phrase.
.FitToPagesTall = UBound(PgBreakRowsArr) + 1
Case FitToPagesTall is 5 in a 16-page document
Case FitToPagesTall is 8
Case FitToPagesTall is 10
Case FitToPagesTall is 13
Case FitToPagesTall is 16 or remove the that code
When creating textboxes in excel, it's impossible to use the search/find text function.
Excel will NOT search for text contained in textboxes.
This is a huge limitation for someone like me, that has 500+ textboxes spread over several worksheets.
I saw many posts of people suggesting solutions that in no way equal or replace the original excel "find text" function.
For example:
https://superuser.com/questions/1367712/find-text-in-the-textbox-in-excel
https://excel.tips.net/T011281_Finding_Text_in_Text_Boxes.html
I am going to share here my workaround hoping to help others as well.
What this vba code does: It exports all the shapes (including textboxes) to a new word document.
In word the search function DOES work in textboxes and the problem is solved.
This is the only solution that equals the crippled excel find text function.
Sub Export()
' THIS must be enabled in Excel: Developer > Visual basic > Tools > References > Microsoft word 1x Object library
'Known bug: if the worksheet has only 1 textbox it will mess up the copy to word. You can manually fix it by adding another textbox in that worksheet. It can be empty.
'Ctrl+break -> will stop the process
'If Word crashes -> the clipboard size is too large.
'Reduce the sheet size or split it in 2 sheets.
'The clipboard limitation is an excel wide limitation.
Dim StartTime As Double
Dim MinutesElapsed As String
StartTime = Timer
MsgBox " Wait for job completed textbox in excel!" & vbCrLf & "Close any other WORD files!"
Dim WordApp As Word.Application
Dim i As Integer
Dim sourceSheet As Worksheet
Set sourceSheet = ActiveSheet
Application.ScreenUpdating = False
Sheet1.Activate
Set WordApp = CreateObject("Word.Application")
On Error Resume Next
WordApp.Documents.Add
With WordApp.ActiveDocument.PageSetup
.PageWidth = InchesToPoints(22)
.PageHeight = InchesToPoints(22)
End With
WordApp.ActiveWindow.View.Type = wdWebView
WordApp.Visible = True
WordApp.Application.ScreenUpdating = False
WS_Count = ActiveWorkbook.Worksheets.Count
For i = 1 To WS_Count
ActiveWorkbook.Sheets(i).Activate
ActiveWorkbook.Sheets(i).Shapes.SelectAll
Selection.Copy
PasteChartIntoWord WordApp
If i <> WS_Count Then
With WordApp.Selection
.Collapse Direction:=0
.InsertBreak Type:=7
End With
End If
Application.CutCopyMode = False
Next i
' Text in textboxes -> apply style: nospacing so that text fits in the textboxes in Word
Dim objTextBox As Object
Dim objDoc As Object
Set objDoc = GetObject(, "Word.Application").ActiveDocument
For Each objTextBox In objDoc.Shapes
If objTextBox.TextFrame.HasText Then
objTextBox.TextFrame.TextRange.ParagraphFormat.LineSpacingRule = 0
objTextBox.TextFrame.TextRange.ParagraphFormat.SpaceAfter = 0
End If
Next objTextBox
Call sourceSheet.Activate
Application.ScreenUpdating = True
WordApp.Application.ScreenUpdating = True
'Determine how many seconds code took to run
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
'Notify user in seconds
MsgBox "Done! " & MinutesElapsed & " minutes", vbInformation
End Sub
Function PasteChartIntoWord(WordApp As Object) As Object
' Remove textbox selection
ActiveCell.Select
Range("BB100").Select
ActiveWindow.SmallScroll up:=100
ActiveWindow.SmallScroll ToLeft:=44
' create a header with sheetname for quick referencing!
WordApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
WordApp.Selection.Font.Size = 36
WordApp.Selection.Font.Underline = wdUnderlineSingle
WordApp.Selection.Font.ColorIndex = wdRed
WordApp.Selection.TypeText Text:=ActiveSheet.Name
' Paste the textboxes
WordApp.Selection.PasteSpecial DataType:=wdPasteShape
End Function
So I have an Excel file, that I want to export some of the rows to another Excel file, my problem is that I have a row that is like:
1
1
1
2
2
2
3
3
3
1
1
1
And I want to export from the first row with number one to the last row with number 3, and after exportation delete that same lines.
So far i have this.
Private Sub export2()
folha = exportform.Label14.Caption
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Dim src As Workbook
' ABRIR EXCEL
Set src = Workbooks.Open("U:\Mecânica\Produção\OEE\OEE ( FULL LOG )\FRS\FRS_DADOS.xlsx", True, False)
WS_Count = src.Worksheets.Count
For o = 1 To WS_Count
src.Worksheets(o).Unprotect password:="registoOEE"
Next o
lastsrc = src.Worksheets("DADOS").Range("A65536").End(xlUp).Row
last = Application.ThisWorkbook.Worksheets(folha).Range("A65536").End(xlUp).Row
Dim last, I As Integer
Dim turno As String
Sheets(folha).Select
For I = 2 To last
'If application.ThisWorkbook.Worksheets(folha).Cells(last, 61)
Next I
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
For o = 1 To WS_Count
src.Worksheets(o).Protect password:="registoOEE"
Next o
Application.DisplayAlerts = False 'IT WORKS TO DISABLE ALERT PROMPT
'SAVES FILE USING THE VARIABLE BOOKNAME AS FILENAME
src.Save
Application.DisplayAlerts = True 'RESETS DISPLAY ALERTS
' CLOSE THE SOURCE FILE.
src.Close True ' FALSE - DON'T SAVE THE SOURCE FILE.
Set src = Nothing
fim:
End Sub
I've edited so you can see what code i have already, hope it helps.
Answering this 10 months old question as it might help someone who is still searching for similar kind of results.
I have put a count if formula in AI column to count the number of occurrences of value in AH and if the the AI value is greater than 1 the same will be pasted in different sheet.
Here is the code:
Sub CopyDups()
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim cnt As Range
Dim nu As Integer
Dim Source As Worksheet
Dim Target As Worksheet
Set Source = ActiveWorkbook.Worksheets("SourceData")
Set Target = ActiveWorkbook.Worksheets("Criteria 1")
nu = 1
For Each cnt In Source.Range("AI1:AI1000")
If cnt > 1 Then
Source.Rows(cnt.Row).Copy Target.Rows(nu)
nu = nu + 1
End If
Next cnt
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
I have a map chart in excel, I'm creating a series of points using zipcodes, but once I'm done with the map I want to remove the borders around each zipcode. I have around 25000 points. I have accomplished this with the following code, but it takes about 2 hours to do this which is not efficient and also every time you try to open the file, it freezes for hours or it just crashes.
Thank you for you help.
Dim aChart As Chart
Dim serPoints As Long
Dim oSer As Series
Dim curPoint As Long
Set aChart = ActiveChart
Set oSer = aChart.SeriesCollection(1)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
serPoints = oSer.Points.Count
'changes the border of the line to 0
For curPoint = 1 To serPoints
oSer.Points(curPoint).Format.Line.Weight = 0
Next curPoint
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
Here is the map before running the code
and here is the map after I run the code