I was writing a macro and when I run the program, it runs fine when reading the first row but when it loops around and does the second row, I get an error, saids automation problem and the macro quits. I was wondering what's going on that it works fine for the first loop but not the second.
Basically, what I want the macro to do it read rows 8 - 25, if the cell has a date in cell (i) (i being 8, 9, 10, etc..), column B then copy row and paste it to another workbook.
Any body have any ideas? thanks! :)
Sub Update()
Dim Request As Workbook
Dim blank As Worksheet
Dim oakfield As Workbook
Set Request = Workbooks("Request_Microbiological_Analysis(blank).xlsm")
Set blank = Request.Worksheets("blank")
Set oakfield = Workbooks.Open("O:\_Public\Quality_Oakfield.xlsm")
With ThisWorkbook
Dim i As Long
For i = 8 To 25
If IsDate(Cells(i, 2)) Then
blank.Cells(i, "A").Resize(, 12).Copy
oakfield.Worksheets("Microlog").Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial xlPasteValuesAndNumberFormats
ActiveWorkbook.Save
ActiveWorkbook.Close
ElseIf IsEmpty(Cells(i, 2)) Then
MsgBox "Oakfield Quality Updated"
End If
Next i
End With
MsgBox "Quality System Updated"
End Sub
Your issue here appears to be due to the fact that you close ActiveWorkbook in your loop, but then don't open it again. An automation error typically occurs when a workbook object is being referenced when it isn't open. You need to wait until after the loop to close your workbook.
Related
I have a very large spreadsheet that currently has 129 tabs. In short, the below macro gets rid of all the array formula errors(#NUM) for each worksheet. This takes about 15-20 minutes but I want to know how close the macro is to finishing.
I designed a Userform progress bar without an issue and I have the code properly referencing the macro. It all works fine except the part that updates the actual Label in the Userform. How can I add code to define what percentage complete the macro is? I am assuming I need to use "current worksheets completed/total worksheet" but I'm extremely new to Userforms.
Sub DelNUM()
Dim LR As Long
Dim i As Long
Dim sh As Worksheet
For Each sh In Worksheets
LR = sh.Range("B" & sh.Rows.Count).End(xlUp).Row
For i = LR To 1 Step -1
If IsError(sh.Range("B" & i)) Then sh.Rows(i).Delete
Next i
Next
End Sub
I already looked at the following link but it is for someone with more experience than me so I am having trouble following it: https://support.microsoft.com/en-us/help/211736/how-to-display-a-progress-bar-with-a-user-form-in-excel
Any and all help would be appreciated.
Thank you,
Sean
In support of #BruceWayne's comment, try this approach instead and see if you run-time decreases significantly:
Three important features in this code to save time are:
Turning off calculations (each row delete statement will trigger a re-calc of the workbook)
Use of SpecialCells to find all possible error cells in one shot!
Deleting rows 1 time per sheet. Each delete call takes up processing time.
Code below:
Option Explicit
Sub DelNUM()
Dim LR As Long
Dim i As Long
Dim sh As Worksheet
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
For Each sh In Worksheets
With sh
LR = .Range("B" & sh.Rows.Count).End(xlUp).Row
Dim formulaErrors As Range
On Error Resume Next 'bc there may not be any error cells
Set formulaErrors = .Range("B1:B" & LR).SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0 'turn error catch back on
If Not formulaErrors Is Nothing Then
formulaErrors.EntireRow.Delete 'now we delete all error rows at once
Set formulaErrors = Nothing 'reset for next loop
End If
End With
Next
Application.Calculation = xlCalculationAutomatic
End Sub
This way you may not need a progress bar :)
I have some code that is meant to open an xlsm workbook, copy some data from it and paste it in the workbook with the code. Both workbooks are password protected and the code is password protected. I have some code that is setup to run before save, open and close which locks the workbook.
So the problem is that the code stops with no errors after the workbook is opened by vba as seen below. I thought it has something to do with the shift key, a problem I have seen all over the net with the open method but I altered the code to fix that and the problem was still there. I then tried removing the code for the on open in the workbook being opened and it worked. Why is this? I have run code just like this before with workbooks that have code on open and it worked just fine.
I am using Excel 2013.
Sub User_Update()
Application.ScreenUpdating = False
Dim strCurrentProgram As String
Dim MainProgramName As String
Dim strLocation As String
strLocation = "X:\Produktionsmesstechnik\Gehaeuse_Freigabe\"
strCurrentProgram = Dir(strLocation & "*.xlsm")
Do While strCurrentProgram <> ""
If InStr(strCurrentProgram, "Gehäuse Freigabe Program Ver") = 1 Then
If MainProgramName = "" Then
MainProgramName = strCurrentProgram
ElseIf CInt(Mid(MainProgramName, 29, 3)) < CInt(Mid(strCurrentProgram, 29, 3)) Then
MainProgramName = strCurrentProgram
End If
End If
strCurrentProgram = Dir
Loop
Workbooks.Open Filename:=strLocation & MainProgramName <<<< CODE STOPS HERE
ActiveWorkbook.Sheets("Users").Range(Cells(4, 1), Cells(100, 11)).Copy
Call UserPassword_Unlock
ThisWorkbook.Sheets("Users").Range("A4").Paste
ThisWorkbook.Save
Workbooks(MainProgramName).Close
Call UserPassword_Lock
End Sub
I can see a couple of things wrong with your code aside from the code stopping.
The code may be stopping due to code in the other workbook firing when it opens, so that needs to be stopped.
The other problems I see are that you're not referencing the newly opened workbook with a variable, instead using ActiveWorkbook which may not always be correct.
The line where you're copy the range is using Users as the range reference, but the cell references are using the currently active sheet.
After your do loop I'd add this code:
Dim wrkBk As Workbook
Application.EnableEvents = False
Set wrkBk = Workbooks.Open(strLocation & MainProgramName)
Call UserPassword_Unlock
With wrkBk.Worksheets("Users")
.Range(.Cells(4, 1), .Cells(100, 11)).Copy _
Destination:=ThisWorkbook.Worksheets("Users").Range("A4")
End With
ThisWorkbook.Save
wrkBk.Close SaveChanges:=False
Call UserPassword_Lock
Application.EnableEvents = True
Note I use wrkBk to reference the newly opened workbook. The Copy and Paste are shortened to a single line with each cell and range reference fully qualified using With wrkbk.Worksheets("Users").
Application.EnableEvents = False should stop any code firing when the workbook is opened.
But even Darren Bartrup-Cook's otherwise fine answer won't suffice if the Shift key is involved ! Vestiges of a bug in XL from 2005! Using the Shift key in a keystroke combination to run a macro will cause execution to halt after the the target workbook opens. For example, CTRL + SHIFT + q to run the macro won't work; CTRL + q will.
Good afternoon everyone. I create a first ever Macro with some of your help and it worked fine until I tested with actual source file that comes from Service-Now report and the only option there .XLS so when I open Source file in Excel 2013 it open in Compatibility Mode and macro give me 'Run time error '9' "Subscript out of range". What should I do to make it work?
Sub HELLO()
Dim x As Workbook
Sheets("Sheet1").Cells.Clear
'## Open workbook first:
Set x = Workbooks.Open("C:\Users\500722\Desktop\dashboard\task.xls")
'Now, transfer values from x to y:
Sheet1.Cells(1, 1) = x.Sheets("Sheet1").Range("A1")
With x.Sheets("Sheet1").UsedRange
'Now, paste to y worksheet:
Sheet1.Range("A1").Resize( _
.Rows.Count, .Columns.Count) = .Value
End With
x.Close
End Sub
As you don't have a worksheet called "Sheet1" in the workbook you opened, your code will fail when you try to access that sheet.
Change all occurrences of x.Sheets("Sheet1") to x.Sheets("Page1") and your problem will probably go away.
Following up from my previous post (of same title). I have a user form from which I need to look up data based on a list of items in a drop down box "XXXXList". The VBA code works partially. The code is able to look for and open the right file from the intranet called "database". But once the file is opened, I get the following error message "Automation error".
The code i have is:
Private Sub ContractsList_AfterUpdate()
Dim WB As Workbook
Dim Sht As Worksheet
' set workbook to workbook location at internet
Set WB = Workbooks.Open("https://Private.Private.Private.uk/Private/Private/Private/Private/Private.xlsm")
Set Sht = WB.Worksheets("Availabledata")
Application.Wait (Now + TimeValue("00:00:01"))
Workbooks("database.xlsm").Close
With Me.XXXXList
'value to be found in Column H of 3rd worhseet
If Not IsError(Application.Match(.Value, Sht.Range("H:H"), 0)) Then
'Lookup values based on first control
Me.TextBox1 = Sht.Range("H" & Application.Match(.Value, Sheet3.Range("H9:H100"), 2)).Value '<-- value not found in Column H
Else
MsgBox "This contract is not on the list"
.Value = ""
Exit Sub
End If
End With
End Sub
Also, the worksheet "database.xlsm" is meant to flash open for a second and then close immediately, but instead it asks me if I want to save the data.
I don't want really want that, is it possible to skip that step and close it automatically?
I'm having a bit of a problem with this VBA code
Sub upONGOING_Train1()
ScreenUpdating = False
'set variables
Dim rFndCell As Range
Dim strData As String
Dim stFnd As String
Dim fCol As Integer
Dim oCol As Integer
Dim SH As Worksheet
Dim WS As Worksheet
Dim strFName As String
Dim objCell As Object
Set WS = ThisWorkbook.Sheets("Trains")
For Each objCell In WS.Range("L3:L100")
oCol = objCell.Column
strFName = WS.Cells(, oCol).Offset(objCell.Row - 1, 0)
On Error GoTo BLANK: 'skip macro if no train
Workbooks.Open Filename:=strFName 'open ongoing report
Set SH = Worksheets("Trains") 'set sheet
stFnd = WS.Cells(, oCol).Offset(objCell.Row - 1, 2).Value 'set connote
With SH
Set rFndCell = .Range("C3:C1100").Find(stFnd, LookIn:=xlValues)
If Not rFndCell Is Nothing Then
fCol = rFndCell.Column
WS.Cells(, oCol).Offset(objCell.Row - 1, 3).Resize(1, 6).Copy
SH.Cells(, fCol).Offset(rFndCell.Row - 1, 10).Resize(1, 6).PasteSpecial xlPasteValues 'paste values in ongoing report if connote found
ActiveWorkbook.Save 'save ongoing report
ActiveWorkbook.Close 'close ongoing report
Else 'Can't find the item
End If
End With
BLANK:
Next objCell
ScreenUpdating = True
End Sub
What I want it to do is - for every row in L3:L100
Open file listed in column "L" (if there or skip line to next one) and go to sheet
Match value from original sheet column "N" to "C3:C1100" in newly opened sheet
Copy columns "O:T" and paste relative to the matching value in the opened sheet(M:R) and save
However when I leave a gap of 2 rows it gives me the error for file not found instead of proceeding to the next loop like it does when there is only 1 row missing.
Seems i can't post images yet.
Also if anyone can point me in a good direction on how to open the sheet in the cell reference only if it is not already open it will usually only have 2 files to use (max of 4 at end of quarter).
Its just too much trouble to click OK on all the windows that pop up when you try to reopen an already open workbook.
If its any help to get your head around it.
I have 2 separate reports for 2 clients(new each quarter so max of 4 sheets at a time) that will already have the names to be searched (2 sheets in each book).
Any help would be greatly appreciated
Thanks heaps
Thanks to those who have put forth suggestions and code.
I'll them out tomorrow and failing that I've just come up with another idea that to re-purpose some other code I have but didn't realize would help.
The code basically copies what I need to a blank tab and deletes rows with a given value - with some formulas to help sort this would give me a block of rows with no breaks all going to the same destination file.
Thus allowing me to run the (a bit more streamlined Thanks everyone) loop over the remaining rows.
On Error GoTo BLANK
Workbooks.Open Filename:=strFName
Change the above into this:
On Error Resume Next
Workbooks.Open Filename:=strFName
If Err.Number <> 0 Then Goto Blank
As to hpw keep the workbook open, you can leave it open (no .close) but then when you want to open it check first if it is open (i.e. using Workbooks("name")), with some error handling using the same mechanism as above, if error exists then the wb is not already open, you open it.
Finally, avoid counting on the Active stuff, such as the ActiveWorkbook`. Instead, make an explicit reference to you wb, i.e.:
Set wb = Workbooks.Open(Filename:=strFName)
Set SH = wb.Worksheets("Trains")
to consider only not blank cells you can use SpecialCells() method of Range object and leave off any On Error GoTo statements, that should be used in very a few limited cases (one of which we'll see in a second)
furthermore you're using some uselessly long winded 'loops' to reference your relevant cells, for instance:
WS.Cells(, oCol).Offset(objCell.Row - 1, 0)
is equivalent to objCell itself!
and there are some more examples of that kind
finally, let's come to the workbooks open/close issue
you could:
use a Dictionary object to store the name of all opened workbooks so as to leave then open throughout your macro and close them all by the end of it
adopt a helper function that tries to set the wanted sheet (i.e. "Trains") in the wanted workbook (i.e. the one whose name is the current objCell value) and return False if not successful
all what above in this refactoring of your code:
Sub upONGOING_Train1bis()
Dim rFndCell As Range
Dim SH As Worksheet
Dim objCell As Range
Dim shtDict As New Scripting.Dictionary '<--| this is the dictionary that will store every opened workbook name as its 'keys'
Dim key As Variant
' Dim dec As String '<--| do you actually need it?
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("Trains") '<-- reference your working worksheet
' dec = .Range("L1") '<-- what's this for? in any case take it out of for loops since its value doesn't depend on current loop variables
For Each objCell In .Range("L3:L100").SpecialCells(xlCellTypeConstants) '<--| loop through L3:L100 range not blank cells only
If TrySetWorksheet(objCell.Value, "Trains", SH) Then '<--|Try to set the wanted worksheet in the wanted workbook: if successful it'd retrun 'True' and leave you with 'SH' variable set to the wanted worksheet
shtDict(SH.Parent.Name) = shtDict(SH.Parent.Name) + 1
Set rFndCell = SH.Range("C3:C1100").Find(objCell.Offset(, 2).Value, LookIn:=xlValues, lookAt:=xlWhole) '<--| specify at least 'LookIn' and 'LookAt' parameters
If Not rFndCell Is Nothing Then rFndCell.Offset(, 10).Resize(, 6).Value = objCell.Offset(, 3).Resize(, 6).Value
End If
Next objCell
End With
For Each key In shtDict.Keys '<--|loop through opened workbooks dictionary keys
Workbooks(key).Close True '<--| close workbook whose name corresponds to current dictionary key
Next
Application.ScreenUpdating = True
End Sub
Function TrySetWorksheet(fileName As String, shtname As String, sht As Worksheet) As Boolean
Set sht = Nothing
On Error Resume Next
Set sht = Workbooks(Right(fileName, Len(fileName) - InStrRev(fileName, "\"))).Worksheets(shtname) '<--| try looking for an already open workbook with wanted name and wanted sheet
If sht Is Nothing Then Set sht = Workbooks.Open(fileName:=fileName).Worksheets(shtname) '<--| if not found then try opening the wanted workbook and set the wanted sheet in it
TrySetWorksheet = Not sht Is Nothing '<--| set the return value to the final result of attempts at locating the wanted sheet
End Function