I'm currently trying to put together some VBA in excel. Not overly familiar, but have managed to collate the following;
Sub PasteBOMLines()
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Set up loop
Dim loopCount As Integer 'Number of cycles to complete
Dim loopCountNow As Integer 'Number of cycles completed so far
loopCount = Range("B4") 'Get number of cycles to complete from cell
loopCountNow = 0 'Set current number of loops to 0
Range("B6:N24").Select
Selection.Copy
Do While loopCount > loopCountNow 'Start of loop, continue looping until the number of loops completed is equal to number of loops to complete
'Paste and Group the relevant cell
ActiveCell.Offset(19, 0).Range("A1:M19").Select
ActiveSheet.Paste
ActiveCell.Offset(3, 0).Range("A1:F16").Select
Selection.Rows.Group
'Resolves loop
loopCountNow = loopCountNow + 1 'integer loops completed by 1
Loop 'returns code to the "do while" bit
'Change settings to default
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub
I'm having issues getting the grouping bit to work. If I leave out this bit;
ActiveCell.Offset(3, 0).Range("A1:F16").Select
Selection.Rows.Group
The copy/paste function works fine, but once added in, the first copy/paste will group, then I get this error;
"Paste method of Worksheet class failed"
Any ideas? Thank you
Related
This code is a part of a larger macro.
Sub testremoveBlankRows()
Dim rng8 As Range
Dim cell As Range
'------------------------------
'Start Timer
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
'-------------------------------------------------
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.CutCopyMode = False
End With
'--------------------------------------------------
ActiveSheet.UsedRange
On Error Resume Next
Set rng8 = Columns("A").SpecialCells(xlBlanks)
On Error GoTo 0
If rng8 Is Nothing Then Exit Sub
For Each cell In rng8.Areas
cell.Cells(1).Offset(0, 0).Resize(cell.Rows.count, 24).Delete xlUp
Next cell
'-------------------------------------------------------------
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.CutCopyMode = False
End With
'-------------------------------------------------------------
'Stop Timer
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
'-------------------------------------
End Sub
This piece of code takes about 85 seconds to run (Sheet1), if I use it in the macro.
If I run code separately (Sheet1), it still takes about 85 seconds to run.
If I open a new Worksheet in original Workbook and copy/paste values, run code separately, it still takes about 85 seconds to run.
If I open a new Workbook and copy/paste values from Sheet1, it takes 0,49 seconds!
What can I do to have it run in 0,49 seconds in the original Workbook?
I would sort on col A and the delete all the rows at once.
Otherwise, if you need to keep the current logic I would turn calculation to Manual during that part Application.Calculation = xlManual (since you mentioned that it takes only 1/2 sec when you copy/paste values in a blank workbook).
And I would rewrite
cell.Cells(1).Offset(0, 0).Resize(cell.Rows.count, 24).Delete xlUp
as
cell.Resize(1, 24).Delete xlUp
or perhaps
cell.EntireRow.delete
I am experiencing baffling behavior with an Excel macro running in Office 365 that I have reduced to the following block. The Excel process becomes corrupted if:
Sheet1!A1:A1000 are filled with letters (just "A" is sufficient). This is to create a sufficiently large computation load in the macro. Too little load and it doesn't break things.
A formula references something that will be altered by the macro. E.g., set Sheet1!B1 formula to =ISNUMBER(E1).
The TestMacro() below is invoked from within the VBA editor (using F5).
(Omit any of these test conditions and the behavior described below does not occur. However with more complex sheets it occurs much more easily, including not requiring the macro be invoked from within the VBA editor.)
Sub TestMacro()
On Error GoTo EH
Dim row As Integer
Dim col As Integer
row = 1
col = 5
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Do While Not IsEmpty(Cells(row, 1).Value)
Cells(1, col).Value = Cells(row, 1).Value & " col"
Cells(3, col).FormulaR1C1 = "test" & Cells(1, col).Value
Range("E2:K2").Select
Selection.Copy
Cells(2, col).Select
ActiveSheet.Paste
Application.CutCopyMode = False
col = col + 8
row = row + 1
Loop
CleanUp:
On Error Resume Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Exit Sub
EH:
' Do error handling
GoTo CleanUp
End Sub
The symptom I check to see whether the macro has messed up Excel is to go to File >> Save As and when things are not right I get a blank dialog screen like this:
Further testing shows that if I omit the two lines in TestMacro that suspend and then resume Application.Calculation then no problems arise.
I have tried putting a simple DoEvents call immediately before Exit Sub but that puts the Excel instance into a state in which the cursor perpetually flits rapidly between normal and Wait.
I suspect there is something structurally incorrect in this VBA subroutine structure, but it is tricky to reveal, and I can't begin to understand what is going wrong.
This is my second post about this macro. Although the first post received a few responses, none of the responses solved the problem (thank you for responding though).
Scenario:
I have about 20 sub-spreadsheets with links to external sources. The number of links per spreadsheet varies from about 500 to 10,000. A master spreadsheet calls macros to open each sub-spreadsheet in turn and update the links.
Each sub-spreadsheet has a dashboard that tells me how many links remain to be updated. This is done by counting the number of “N/A” values in each tab, then summing these counts in cell A20. As the links are updated, the value in A20 counts down to zero.
Sub Sub01()
Dim NAtotal As Integer
Set ActiveWKB = Workbooks.Open("Sub01.xlsm")
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.CalculateFull
ActiveWorkbook.UpdateLink Name:=ActiveWorkbook.LinkSources
NAtotal = Worksheets("Dashboard").Cells(20, "C").Value
MsgBox (NAtotal) 'Tells me how many cells remain to be updated – starts off at 4450.
NAtotal = 100 'Debugging effort to let me know that NAtotal does adjust.
MsgBox (NAtotal)
Do Until NAtotal = 0
Application.ScreenUpdating = True
MsgBox (NAtotal) 'Another debugging effort to monitor NAtotal. Starts at 100, then jumps to (and remains at) 4450 on the second loop and all subsequent loops.
NAtotal = Worksheets("Dashboard").Cells(20, "C").Value 'Resets NAtotal to the value in C20. This never changes, but remains at 4450.
DoEvents
Loop
Application.Calculation = xlManual
MsgBox ("Done")
Sheets("Dashboard").Activate
Range("B1").Select
ActiveWorkbook.Save
ActiveWindow.Close
End Sub`
The macro should continue to loop until cell A20 hits zero, and then stop.
Cell A20 does count down, but variable NAtotal remains at its initial value.
Any guidance/recommendations are appreciated.
Hi the code below worked for me. Try use the same method instead of using a loop. The schedule will trigger every second until the NATotal = 0 logically anyway. Just update the code to fit your references.
Public firstOpen As Boolean
Sub testForm()
Dim cellCount As Integer
Dim s1 As Sheet1
Set s1 = Sheet1
Dim cellCol As Integer
Dim activeWbk As Workbook
Dim ws As Worksheet
If firstOpen = False Then
firstOpen = True
Set activeWbk = Workbooks.Open("C:\Example\Link2.xlsm")
Set ws = activeWbk.Sheets("Sheet1")
Application.Calculation = xlCalculationAutomatic
Application.CalculateFull
activeWbk.UpdateLink Name:=ActiveWorkbook.LinkSources
CreateNewSchedule
Exit Sub
Else
Set activeWbk = Workbooks("Link2.xlsm")
Set ws = activeWbk.Worksheets("Sheet1")
End If
cellCount = ws.Range("N2").Value
If cellCount = 0 Then
MsgBox ("Done...")
Application.Calculation = xlCalculationManual
firstOpen = false
Else
Debug.Print cellCount
CreateNewSchedule
End If
'Application.Calculation = xlCalculationManual
End Sub
Sub CreateNewSchedule()
Application.OnTime Now + TimeValue("00:00:01"), Procedure:="testForm", Schedule:=True
End Sub
I'm using this formula to delete empty columns in my sheet. But it takes around 15-20min to delete them. Can I somehow speed up this proces? It's weird that it takes so long and I'm only working with 100 columns.
For j = 1 To 5
For i = 40 To 146
If Sheet8.cells(4, i) = "" Then
Columns(i).EntireColumn.Delete
End If
Next i
Next j
If you have real bank cells use #Patrick Honorez answer using SpecialCells(xlCellTypeBlanks) which is faster.
But if you have no real blank cells (eg formulas that show as "") then you can use this:
Dim DeleteRange As Range
With sheet8
Dim i As Long
For i = 40 To 146
If .Cells(4, i).Value = vbNullString Then 'vbNullString = ""
If DeleteRange Is Nothing Then
Set DeleteRange = .Columns(i)
Else
Set DeleteRange = Union(DeleteRange, .Columns(i))
End If
End If
Next i
End With
If Not DeleteRange Is Nothing Then 'check if there is something to delete
DeleteRange.EntireColumn.Delete
End If
It collects all columns that you want to delete in DeleteRange and then deletes them at once. This is faster than deleting each column on its own, because each delete action needs its time (and here we have only one delete action).
Note that we don't need to loop backwards here because we only collect the columns within the loop but delete action comes after the loop, so it doesn't affect the loop counting at all.
Try:
For i = 146 To 40 step -1
If Sheet8.cells(4, i) = "" Then
Columns(i).EntireColumn.Delete
End If
Next i
Try adjusting this for your needs. I think nothing can go faster :-)
Sub test()
Range("C3:j17").SpecialCells(xlCellTypeBlanks).EntireColumn.Delete
End Sub
I would suggest to do it like that.
Option Explicit
Private Sub TurnOffFunctionality()
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.ScreenUpdating = False
End Sub
Private Sub TurnOnFunctionality()
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub TestIt()
Dim i As Long
TurnOffFunctionality
For i = 146 To 40 Step -1
If Sheet8.Cells(4, i) = "" Then
Columns(i).EntireColumn.Delete
End If
Next i
TurnOnFunctionality
End Sub
Turning off especially re-calculation will make sure that a re-caculation is not triggered with every deletion of a single column in the loop. This could probably be the cause of the long run time.
I am relatively new to VBA. And when I was working on a worksheet I created a code that automatically hides/unhides rows based on a condition in a column row (0 unhide/1 hide). This relatively easy macro worked well until I added a different sheet. As there are no macros in this sheet I dont think it is related. But now everytime it gives a runtime error on the END IF function and I don't know how to solve it. There is probably a simple solution, but I cannot find it.
Here is the code:
Private Sub Worksheet_Calculate()
Application.ScreenUpdating = False
Dim LastRow As Long, c As Range
Application.EnableEvents = False
LastRow = Cells(Cells.Rows.Count, "BA").End(xlUp).Row
On Error Resume Next
For Each c In Range("BA34:BA56,BA73:BA74,BA76:BA107")
If c.Value = 1 Then
c.EntireRow.Hidden = True
ElseIf c.Value = 0 Then
c.EntireRow.Hidden = False
End If
Next
On Error GoTo 0
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Remove or comment out the On Error Resume Next if you want more complete debugging information. It should not be necessary in an event macro that runs as often as Worksheet_Calculate.
Apply a parent worksheet reference to the range object. The worksheet may have volatile formulas that are triggering a calculation event due to changes on the other worksheet.
I've added a wide condition so that the code will only run if the parent worksheet holds the ActiveSheet property. The worksheet may have volatile¹ formulas that are triggering a calculation event due to changes on the other worksheet (or even another workbook).
LastRow does nothing after its assignment (which is problematic) so I removed it.
I simplified the Range.Hidden property to a single line.
Private Sub Worksheet_Calculate()
If Me.Name = Activesheet.Name Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim c As Range
For Each c In Me.Range("BA34:BA56,BA73:BA74,BA76:BA107")
c.EntireRow.Hidden = CBool(c.Value2)
Next c
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
¹ Volatile functions recalculate whenever anything in the entire workbook changes, not just when something that affects their outcome changes. Examples of volatile functions are INDIRECT, OFFSET, TODAY, NOW, RAND and RANDBETWEEN. Some sub-functions of the CELL and INFO worksheet functions will make them volatile as well.
Just to finish the thread. I solved it based on a combination of the code you wrote and mine, as the 0 should be the trigger to unhide as well. I guess the error line caused the issue.
Private Sub Worksheet_Calculate()
Application.ScreenUpdating = False
Dim LastRow As Long, c As Range
Application.EnableEvents = False
LastRow = Cells(Cells.Rows.Count, "BA").End(xlUp).Row
On Error Resume Next
For Each c In Range("BA34:BA56,BA73:BA74,BA76:BA107")
If c.Value = 1 Then
c.EntireRow.Hidden = True
ElseIf c.Value = 0 Then
c.EntireRow.Hidden = False
End If
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub