I have being doing research on why I am unable to set my workbook for the past couple of hours. What I am trying to do is go through each spreadsheet within a folder to refresh the data and import them using Vlookup at the Set Book2 = workbooks("InfoPedia Page Views (ASG Compete)") is when I am getting an error
Run-time error '9': Subscript out of range
Please, if anyone can tell why my code isn't working, I would really appreciated it.
enter code here
Sub Test()
Dim Book2 As Workbook
Set fso = CreateObject("Scripting.FileSystemObject")
Set xl = CreateObject("Excel.Application")
xl.Visible = True
For Each f In fso.getfolder("C:\Users\v-gazhan\Desktop\Infopedia Quality Project\Infopedia Quality Dashboard\Page Views").Files
If LCase(fso.GetextensionName(f.Name)) = "xlsx" Then
Set wb = xl.workbooks.Open(f.Path)
' Set the correct month
wb.SlicerCaches("Slicer_Month_Name").VisibleSlicerItemsList = Array _
( _
"[Time].[Month Name].&[10]")
With Application.WorksheetFunction
If fso.getbasename(f.Name) = "InfoPedia Page Views (ASG Compete)" Then
***Set Book2 = workbooks("InfoPedia Page Views (ASG Compete)")***
Set SearchRange = Book2.Sheets("Page Views Sorted Most to Least").Range("B:D")
ActiveWorkbook.Sheets("Reference").Cells(1, 4).Value = .VLookup(Sheets("reference").Range("B1"), SearchRange, 3, False)
End If
End With
wb.Close
End If
Next
xl.Qu
End Sub
Related
When I make a call to open a connection to another workbook, occasionally the workbook will open fully in Excel. I have ~15 data sets I pull using this method and I have not been able to identify a pattern. yesterday the refresh was quick and seamless and no workbooks visibly opened in Excel. Today 1 of 2 is opening in Excel.
Since I have users of varying experience with Excel, I would like to eliminate this possibly confusing behavior.
oCnC.Open "Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Data Source=" & Filename & ";Extended Properties=""Excel 12.0; HDR=YES;"";"
Example code:
sub Caller
Set dTabs = New Dictionary
Set dTabs("Cerner") = New Dictionary
dTabs("Cerner")("Query") = "Select Field1, Field2 from [Sheet1$]"
dTabs("Cerner")("Hidden") = 1
Call GetMasterTables("\\\Files\File1.xlsx", dTabs)
dTabs.RemoveAll
Set dTabs = New Dictionary
Set dTabs("SER") = New Dictionary
dTabs("SER")("Query") = "Select [1],F75 from [Sheet1$]"
dTabs("SER")("Hidden") = 1
Call GetMasterTables("\\Files\File2.xlsx", dTabs)
dTabs.RemoveAll
(Cleanup)
End Sub
Private Sub GetMasterTables(Filename As String, dTabset As Dictionary, ByRef wb As Workbook)
Dim oCnC As Connection
Dim rsC As Recordset
Dim rsE As Recordset
Dim lo As ListObject
Dim rngHome As Range
Set oCnC = New Connection
Set rsC = New Recordset
Set rsE = New Recordset
Dim ws As Worksheet
oCnC.Open "Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Data Source=" & Filename & ";" & _
"Extended Properties=""Excel 12.0; HDR=YES;"";"
rsC.ActiveConnection = oCnC
For Each i In dTabset
If SheetExists(i, wb) Then
Set ws = wb.Sheets(i)
ws.Visible = xlSheetVisible
Else
Set ws = wb.Sheets.Add(, wb.Sheets(wb.Sheets.count))
ws.Name = i
ws.Visible = xlSheetVisible
End If
Set rngHome = ws.Range("A1")
If RangeExists("Table_" & Replace(i, "-", "_"), ws) Then
Set lo = ws.ListObjects("Table_" & Replace(i, "-", "_"))
lo.DataBodyRange.Delete
Else
Set lo = ws.ListObjects.Add(, , , xlYes, rngHome)
lo.Name = "Table_" & Replace(i, "-", "_")
lo.DisplayName = "Table_" & Replace(i, "-", "_")
End If
If dTabset(i).Exists("Query") Then
rsC.Source = dTabset(i)("Query")
Else
rsC.Source = "Select * from [" & i & "$]"
End If
rsC.Open
rsC.MoveFirst
ws.Range(lo.HeaderRowRange.Offset(1, 0).address).Value = "hi"
lo.DataBodyRange.CopyFromRecordset rsC
rsC.MoveFirst
For Each j In lo.HeaderRowRange.Cells
j.Value = rsC.Fields(j.Column - 1).Name
Next j
rsC.Close
If dTabset(i).Exists("Hidden") Then
ws.Visible = xlSheetHidden
Else
ws.Visible = xlSheetVisible
End If
Next i
End Sub
Function SheetExists(ByVal shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ActiveWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
SheetExists = Not sht Is Nothing
End Function
Function RangeExists(ByVal rngName As String, Optional ws As Worksheet) As Boolean
Dim rng As ListObject
If ws Is Nothing Then Set ws = ActiveWorksheet
On Error Resume Next
Set rng = ws.ListObjects(rngName)
On Error GoTo 0
RangeExists = Not rng Is Nothing
End Function
Update 1
Ah-ha! I have an update.
After the last test I had left the workbook open. When I came back to the computer after a few minutes there was a prompt up that the file was available for editing. Perhaps the intermittent behavior is due to the requested file being open by another user. I tested this theory by closing the workbook and then re-running the sub and it did not open the file in the app.
Update 2
Qualified my sheets references. Issue is still happening.
The issue is here (and anywhere else you're using Sheets without an object reference):
Set ws = Sheets(i)
ws.Visible = xlSheetVisible
Sheets is a global collection of the Application, not the Workbook that the code is running from. Track down all of these unqualified references and make them explicit:
Set ws = ThisWorkbook.Sheets(i)
You should also pass your optional parameter here:
'SheetExists(i)
'...should be...
SheetExists(i, ThisWorkbook)
I'm guessing the reason this is intermittent is that you're catching instances where the ADO connection has the other Workbook active, and your references aren't pointing to where they're supposed to.
In addition to the code review offered by #Comintern and #YowE3K I found a solution in the following:
Qualify my workbooks, and my sheets
Turn off screen updating (so the users can't see my magic)
Throw the book names in a dictionary before I do my update and close any extras that opened during the update.
Application.ScreenUpdating = False
For i = 1 To Application.Workbooks.count
Set dBooks(Application.Workbooks(i).Name) = i
Next i
Application.ScreenUpdating = False
Code from question
For i = 1 To Application.Workbooks.count
If dBooks.Exists(Application.Workbooks(i).Name) Then
dBooks.Remove (Application.Workbooks(i).Name)
Else
dBooks(Application.Workbooks(i).Name) = i
End If
Next i
For Each bookname In dBooks
Application.Workbooks(bookname).Close (False)
Next
Application.ScreenUpdating = True
I know that I could do something like..
range("C1:D1").copy destination:=range("C2:D2")
for ranges, I would like to know if I can do the same for form control buttons
Current code below copies the button if found and then adds the button to the cell where the "hash tag" was written. In this example "#Button Back To Summary#". This all works fine but I would like to change the code to not go via the clipboard, for example like the above code for a range but for a form button.
Calling Code:
On Error Resume Next
Cells.Find(What:="#Button Back To Summary#", After:=ActiveCell, LookIn:= _
xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _
, MatchCase:=False, SearchFormat:=False).Activate
If Err.Number = 0 Then
addshapetocell ActiveCell, "BK_TO_SUMMARY"
End
DoEvents
On Error GoTo 0
addshapetocell()
Sub addshapetocell(p As Range, btn_Name As String)
Dim clLeft As Double
Dim clTop As Double
Dim cl As Range
Dim r As Integer, R1 As Integer
On Error GoTo 0
R1 = 0
r = 0
Set cl = Range(p.Address)
clLeft = cl.Left
clTop = cl.Top
cl.value = ""
retryer:
update_Working_Status
Application.CutCopyMode = False
DoEvents
If r > 5000 Or R1 > 700 Then
MsgBox "Code has attempted to copy a button 5000 times and has failed each time"
Stop
End If
Worksheets("Odds").Shapes(btn_Name).Copy
DoEvents
If Application.ClipboardFormats(1) = 0 Then
R1 = R1 + 1
Sleep (50)
GoTo retryer
End If
With ActiveSheet
On Error Resume Next
.Paste
If Err.Number = 1004 Then
On Error GoTo 0
r = r + 1
Sleep (50)
GoTo retryer
ElseIf Err.Number <> 0 Then
Stop 'unhandled error has happend
End If
On Error GoTo 0
.Shapes(btn_Name).Left = clLeft
.Shapes(btn_Name).Top = clTop
End With
End Sub
Edit: update_Working_Status updates the status bar with "Working." & "Working.." etc
I don't believe there is a way to directly copy the Shape from one Worksheet to another without using the Clipboard. There is a .Duplicate method but I'm not aware of a way to change the Shapes Parent ie. which Worksheet it belongs to.
Have you considered programmatically re-creating the Shape using your template Shape as a base? This would be, effectively, copying the Shape but with a bit more effort involved. I've written the following as an example of how you could do this which, hopefully, you can adapt to your exact needs.
Dim wb As Workbook
Set wb = Application.ActiveWorkbook
' Worksheet Receiving the Template Shape ie. the ActiveSheet.
Dim ws As Worksheet
Dim rng As Range
Dim newShape As Shape
Set ws = wb.ActiveSheet
Set rng = ws.Range("B10") ' Destination Cell.
' Worksheet containing the Template Shape.
Dim wsTemplate As Worksheet
Dim shapeToCopy As Shape
Set wsTemplate = wb.Sheets("Template") ' The Worksheet containing template button.
Set shapeToCopy = wsTemplate.shapes("#example") ' The name of template button.
' Different 'Shapes' are created via different Methods, so check the types that you want
' to support and implement the Method as appropriate.
Select Case shapeToCopy.Type
Case MsoShapeType.msoFormControl
' Create the 'new' Shape based on the type and size of the template, and the location of the receiving Cell.
Set newShape = ws.shapes.AddFormControl(shapeToCopy.FormControlType, rng.Left, rng.Top, shapeToCopy.Width, shapeToCopy.Height)
newShape.OLEFormat.Object.Text = shapeToCopy.OLEFormat.Object.Text ' Copy the template buttons caption.
Case Else
' Unsupported Shape Type
Exit Sub
End Select
' Now "Copy" the remaining shared Shape properties that we want to retain from the template.
newShape.Name = shapeToCopy.Name
newShape.AlternativeText = shapeToCopy.AlternativeText
newShape.OnAction = shapeToCopy.OnAction ' The name of the routine to run on button click
' etc...
' etc...
In sheet1 I have an invisible activeX control (Oleobject): commandbutton1
It can be placed alongside the 'hash tag' cell, using:
Sub M_snb()
With Cells.Find("hash tag").Offset(, 1)
Sheet1.CommandButton1.Top = .Top
Sheet1.CommandButton1.Left = .Left
Sheet1.CommandButton1.Visible = True
End With
End Sub
Below is a macro for Excel2010 in VBA. It's working only when I open VBA Code editor and run from the menu Debug. I tried to put it to Ribbon and run it from there but I've got this error:
Run-time error '1004':
Application-defined or object-defined error
Additionally, when I change all Range() into .Worksheet(i).Range(), the procedure does not run at all with the same error. It's like .Range does not seem to be part of Worksheet(i). I have no experience in Excel 2010 VBA.
Sub CopyAndRearrange()
Dim ns As Integer
Dim i As Integer
ns = ActiveWorkbook.Worksheets.Count
ActiveWorkbook.Sheets(ns).Cells.ClearContents
For i = 1 To ns - 1
With ActiveWorkbook
.Worksheets(i).Activate
Range("E1") = CInt(.Worksheets(i).Name)
Range(Range("G1"), Range("A1").End(xlDown).Offset(0, 7)) = "=IF(RC[-6]=0,"""",RC[-6] + R4C5"
Range(Range("I1"), Range("A1").End(xlDown).Offset(0, 8)) = "=RC[-6]"
Range(Range("G1"), Range("I1").End(xlDown)).Copy
Sheets(ns).Activate
If i = 1 Then
'Range(Range("G1"), Range("I1").End(xlDown)).Copy Destination:=Sheets(ns).Range("A1")
Sheets(ns).Range("A1").Select
Else
'Range(Range("G1"), Range("I1").End(xlDown)).Copy Destination:=Sheets(ns).Range("A1").End(xlDown).Offset(1, 0)
Sheets(ns).Range("A1").End(xlDown).Offset(1, 0).Select
End If
ActiveSheet.Paste Link:=True
Application.CutCopyMode = False
Application.ScreenUpdating = True
End With
Next
Sheets(ns).Range("A1").Select
End Sub
EDIT:
OK. I have slightly changed the code in hope I was wrong about referring to the right sheet etc. The problem is still there. The line: ActiveSheet.Range(rg1, rg1) = "=IF(RC[-6]=0,"""",RC[-6] + R4C5" causes the problem. Surprisingly, it is not the first that I refer to Range in the an active sheet and for some reasons, I really don't know why, I've got the error!!! To exhaust all possibilities, I have also tried these:
Explicitly re-create a Module in VBA Window
Re-open the file
Record a macro and insert a code in there
Nothing's worked so far. I have given up but maybe someone in future will see the problem and give a solution here.
Public Sub CopyAndRearrange()
Dim ns As Integer
Dim i As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim rg1 As Range
Dim rg2 As Range
Dim cell As Range
Set wb = ThisWorkbook
ns = wb.Worksheets.Count
wb.Sheets(ns).Cells.ClearContents
For i = 1 To ns - 1
With wb
Set ws = wb.Worksheets(i)
ws.Activate
ActiveSheet.Range("E1") = CInt(ActiveSheet.Name)
Set rg1 = ActiveSheet.Range("G1")
Set rg2 = ActiveSheet.Range("A1").End(xlDown).Offset(0, 7)
ActiveSheet.Range(rg1, rg1) = "=IF(RC[-6]=0,"""",RC[-6] + R4C5"
Set rg1 = ActiveSheet.Range("I1")
Set rg2 = ActiveSheet.Range("A1").End(xlDown).Offset(0, 8)
ActiveSheet.Range(rg1, rg2) = "=RC[-6]"
Set rg1 = ActiveSheet.Range("G1")
Set rg2 = ActiveSheet.Range("I1").End(xlDown)
ActiveSheet.Range(rg1, rg2).Copy
Sheets(ns).Activate
If i = 1 Then
ActiveSheet.Range("A1").Select
Else
ActiveSheet.Range("A1").End(xlDown).Offset(1, 0).Select
End If
ActiveSheet.Paste Link:=True
Application.CutCopyMode = False
Application.ScreenUpdating = True
End With
Next
Sheets(ns).Range("A1").Select
Set ws = Nothing
Set wb = Nothing
Set rg1 = Nothing
Set rg2 = Nothing
Set cell = Nothing
End Sub
Try the following:
Sub CopyAndRearrange(Control as IRibbionControl)
Adding the control allows the code to be executed from the ribbion.
I guess I found the answer to my own question.
The problem was missing bracket in this line:
ActiveSheet.Range(rg1, rg1) = "=IF(RC[-6]=0,"""",RC[-6] + R4C5"
which should be:
ActiveSheet.Range(rg1, rg1) = "=IF(RC[-6]=0,"""",RC[-6] + R4C5)"
If the error was more intelligible, I would not lose 2 days to look for this problem :/
I'm trying to open two documents from excel with vba and call a word macro from this particular excel file.
The macro is working fine in Word and I also get the documents to open and the word macro to start. However when there is a switch from one document to the other the word macro goes to break-mode (which does not happen when I run it from Word instead of Excel).
I use the following code from excel:
Set wordApp = CreateObject("Word.Application")
worddoc = "H:\Word Dummy's\Dummy.docm"
wordApp.Documents.Open worddoc
wordApp.Visible = True
wordApp.Run macroname:="update_dummy", varg1:=client, varg2:=m_ultimo, varg3:=y
In word I have a sub with the parameters defined between breakets and the following code:
worddoc2 = "H:\Word Dummy's\texts.docx"
Word.Application.Activate
Documents.Open worddoc2, ReadOnly:=True
ThisDocument.Activate
Set bmks = ThisDocument.Bookmarks
Can anyone tell me why it does not run from excel and how I can fix this?
Thanks in advance.
I finally found the answer myself after a lot of searching on Google.
I needed to add :
application.EnableEvents=false
To the excel macro.
That was all. Now it works.
My complete code is huge (the macro in excel also opens two other workbooks and runs a macro in them). This part of the code is working for now (so I left it out), but I just want to add the part that it opens a worddoc and adds specific texts in it depending on what client has been chosen in the excel userform. But to show you a better idea how my code looks like, this is in excel (where the client is defined by a userform in another module):
Sub open_models (client as string)
Application.DisplayStatusBar = True
‘determine datatypes
Dim m_integer As Integer
Dim m_ultimo As String
Dim m_primo As String
Dim y As String
Dim y_integer As Integer
Dim y_old As String
Dim y_last As String
Dim wordApp As Object
Dim worddoc As String
'Determine current month and year and previous
m_integer = Format(Now, "mm")
y_integer = Format(Now, "yyyy")
If m_integer <= 9 Then
m_ultimo = "0" & m_integer - 1
m_primo = "0" & m_integer - 2
Else
m_ultimo = m_integer - 1
m_primo = m_integer - 2
End If
If m_integer = 1 Then
y = y_integer - 1
Else
y = y_integer
End If
On Error Resume Next
'open word dummy
Set wordApp = CreateObject("Word.Application")
worddoc = "H:\RAPORTAG\" & y & "\" & y & m_ultimo & "\Dummy.docm"
wordApp.Documents.Open worddoc
wordApp.Visible = True
wordApp.Run macroname:="update_dummy", varg1:=client, varg2:=m_ultimo, varg3:=y, varg4:= worddoc)
On Error GoTo 0
ThisWorkbook.Activate
'reset statusbar and close this workbook
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
ThisWorkbook.Close False
End Sub
And this is the code in word I am using:
Sub update_dummy(client As String, m_ultimo As String, y As String, worddoc as string)
Dim wordapp As Object
Dim rngStart As Range
Dim rngEnd As Range
Dim worddoc As String
Dim worddoc2 As String
Dim dekkingsgraad As String
Dim bmks As Bookmarks
Dim bmRange As Range
Dim rng As Range
Dim i As Boolean
On Error Resume Next
worddoc2 = "H:\RAPORTAG\" & y & "\" & y & m_ultimo & "\dummytexts.docx"
'open other word
Documents.Open worddoc2, ReadOnly:=True
Documents(worddoc).Activate
Set bmks = Documents(worddoc).Bookmarks
'management summary
If client <> "PMT" Then
i = True
Set rngStart = Documents(worddoc2).Bookmarks("bn0_1_start").Range
Set rngEnd = Documents(worddoc2).Bookmarks("bn0_1_end").Range
End If
If i = True Then
Set rng = Documents(worddoc2).Range(rngStart.Start, rngEnd.End)
rng.Copy
Set bmRange = Documents(worddoc).Bookmarks("bmManagementsummary").Range
bmRange.PasteAndFormat (wdPasteDefault)
End If
i = False
On Error GoTo 0
End Sub
I have 20 more bookmarks that are defined but the code for them is all the same.
I have seen and solved this problem a few times before, the solution I found was odd.
Copy paste all your code into a text
editor, 1 for word, 1 for excel
Delete all the macros in word or excel or better yet, just create
new files.
Paste all the code into word/excel from your text editor.
I've definitely had this 3 or 4 times in Excel and Access. Especially if you previously had a breakpoint at that location.
It sounds stupid but try it and see if that works, this has saved me from insanity a few times.
Forgive me if this is a noob question but I have spent hours crawling this site for an answer.
I am trying to write a macro that will loop through all of my worksheets and delete all that are not in a pre-defined array. However I am having difficulty comparing the worksheet names in the array to the actual names in the workbook. Here is my code:
Dim DoNotDelete(10) As Worksheet
Dim sh As Worksheet
Dim dnd As Worksheet
Set DoNotDelete(0) = ThisWorkbook.Worksheets("Home")
Set DoNotDelete(1) = ThisWorkbook.Worksheets("Global Statistics")
Set DoNotDelete(2) = ThisWorkbook.Worksheets("Summary")
Set DoNotDelete(3) = ThisWorkbook.Worksheets("Project Dependencies")
Set DoNotDelete(4) = ThisWorkbook.Worksheets("Completed Projects")
Set DoNotDelete(5) = ThisWorkbook.Worksheets("Risk Overview- Yellow")
Set DoNotDelete(6) = ThisWorkbook.Worksheets("Issue Overview- Red")
Set DoNotDelete(7) = ThisWorkbook.Worksheets("Issue Overview- Red")
Set DoNotDelete(8) = ThisWorkbook.Worksheets("Dependencies")
Set DoNotDelete(9) = ThisWorkbook.Worksheets("Completed Data")
Set DoNotDelete(10) = ThisWorkbook.Worksheets("Data")
For Each sh In Worksheets
Delete = False
For Each dnd In DoNotDelete
If dnd = sh Then
Delete = False
Exit For
Else
Delete = True
End If
Next dnd
If Delete = True Then
ThisWorkbook.Worksheets(sh).Delete
End If
Next sh
It errors out every time at:
If dnd = sh then
I am using Excel 2007 (dont ask...). Any suggestions would be much appreciated!
You have to check reference equality with the is keyword
If dnd is sh Then
Delete = False
Exit For
Else
Delete = True
End If
Another way, compare an identifying or unique property:
If dnd.Name = sh.Name Then
Delete = False
Exit For
Else
Delete = True
End If
Try using
If dnd.Name = sh.Name Then
-- stuff here
End If
How about this? Explainations in the comments
Sub DeleteWorksheets()
Dim ws As Worksheet 'Used to loop through all worksheets in workbook
Dim ArrayElement As Variant 'Used to loop through all elements in the array
Dim DoNotDelete(0 To 10) As String 'Used to store NAMES of worksheets rather than objects
Dim Found As Boolean 'Used to test whether or not the worksheet in found in the array
'Store values as strings
DoNotDelete(0) = "Home"
DoNotDelete(1) = "Global Statistics"
DoNotDelete(2) = "Summary"
DoNotDelete(3) = "Project Dependencies"
DoNotDelete(4) = "Completed Projects"
DoNotDelete(5) = "Risk Overview- Yellow"
DoNotDelete(6) = "Issue Overview- Red"
DoNotDelete(7) = "Issue Overview- Red"
DoNotDelete(8) = "Dependencies"
DoNotDelete(9) = "Completed Data"
DoNotDelete(10) = "Data"
For Each ws In Worksheets 'For every worksheet in this workbook
Found = False 'Reset Found value to false
For Each ArrayElement In DoNotDelete 'Check if worksheet name is found in array
If ws.Name = ArrayElement Then 'If it is, set Found to true and exit the loop
Found = True
Exit For
End If
Next ArrayElement
If Found = False Then 'If worksheet name isn't in the array, delete it
ws.Delete
End If
Next ws
End Sub