I have gone through the similar questions and have not found anything with this specific error.
I am trying to make a macro that goes through a large number of CSV files, pulls the necessary information I need, copies and pastes that data to a new Workbook, and then closes the CSV file and goes to the next one.
When I test my code and have it run Step by Step (using F8) it functions fine and there are no error. However, whenever I try and just have the code run (like pressing F5) I get the error "PasteSpecial Method of Class Range" failed. When I press debug this line of the code is highlighted:
copyRange.Offset(0, 1).PasteSpecial Paste:=xlPasteValues
I added a small time delay of 0.5s before this line and it actually was able to go further through the files before failing.
Is it something with the Range.Offset method? Should I explicitly define a different copy range?
Code I have follows below:
Public Sub OpenTXT_CopyNewWBK(inPath As String)
Application.ScreenUpdating = False
Dim fso, oFolder, oSubfolder, oFile, queue As Collection
Dim app As New Excel.Application
app.Visible = True
Dim dataRange As Range, dateRange As Range, copyRange As Range
Dim lastCell, lastRow As String
Dim newBook, wbk As Excel.Workbook
Dim csvStart As Long
Set newBook = Workbooks.Add
With newBook
.SaveAs Filename:="BETA RAY " & Format(Now, "ddmmyyhhmmss")
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
queue.Add fso.GetFolder(inPath) 'obviously replace
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Do While queue.Count > 0
Set oFolder = queue(1)
queue.Remove 1 'dequeue
For Each oSubfolder In oFolder.SubFolders
queue.Add oSubfolder 'enqueue
Next oSubfolder
For Each oFile In oFolder.Files
Set wbk = app.Workbooks.Add(oFile.Path)
lastCell = wbk.Sheets(1).Range("A1").End(xlDown).Address
If Len(lastCell) = 6 Then
lastRow = Mid(lastCell, 4, 3)
ElseIf Len(lastCell) = 5 Then
lastRow = Mid(lastCell, 4, 2)
ElseIf Len(lastCell) = 4 Then
lastRow = Mid(lastCell, 4, 1)
End If
Set dateRange = wbk.Sheets(1).Range("A2", lastCell)
dateRange.Select
Set dataRange = wbk.Sheets(1).Range("AA2", "AM" & lastRow)
dataRange.Select
wbk.Application.CutCopyMode = True
Set copyRange = Workbooks(newBook.name).Sheets(1).Range("A1048576").End(xlUp)
If Not copyRange = "" Then
Set copyRange = copyRange.Offset(1, 0)
End If
dateRange.Copy
copyRange.PasteSpecial Paste:=xlPasteValues
wbk.Application.CutCopyMode = False
wbk.Application.CutCopyMode = True
Application.Wait (Now + 500 * 0.00000001)
dataRange.Copy
copyRange.Offset(0, 1).PasteSpecial Paste:=xlPasteValues
wbk.Application.CutCopyMode = False
wbk.Close SaveChanges:=False
Next oFile
Loop
app.Quit
Set app = Nothing
Range("B:B").Delete
Range("G:G").Delete
Range("L:L").Delete
Application.ScreenUpdating = True
End Sub
I am sure there are much better ways to do a lot of the things I have going on there. I really just use VBA to make my life easier at work so a lot of the code I use is copy, pasted, and modified to fit my needs. I couldn't figure out how to make this method work wbk2.sht2.Range("A1:A5") = wbk1.sht1.Range("B1:B5") everything I have read says this should be a much better method. Also, the portions of code that read dataRange.Select and dateRange.Select are just there for debugging purposes.
try this....
wbk2.sht2.Range("A1:A5").value = wbk1.sht1.Range("B1:B5").value
Related
I have been running this code in my day to day work to keep on top of my orders and shipping, the code opens a spreadsheet in a specified location and returns the following, invoice number, company name, shipping date and total order value and puts them into one main spreadsheet.
I started using it last year and it used to take just under 3 minutes to run through about 400-500 spread sheets to collect the data. now I have a similar amount of data to run through this year but the report takes hours!!
I haven't changed my report and the data is the same data from the same template just in a different folder but in the same location on the same drive under the same parent folder.
I don't think it s the change of location that has slowed it down.
I have included a copy of my code below with notes under most of the code to explain the function of each line, can anyone see any problems with the code or recommend any improvements?
Sub Invoice_Records()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim FileExt As String
Dim CellValue As Range
Dim Text As String
Dim Text2 As String
Dim Text3 As String
Dim Total As Range
Dim filecountB As String
Dim i As String
Dim ws As Worksheet
Dim Invoice_Count As Integer
Set ws = Worksheets("Admin2")
'This part clears all columns, otherwise if you were on line 10 last time you ran the code,
'and then you deleted a commercial invoice it would only update up to line 9 but the legacy values of line 10 would still show
ws.Columns(2).EntireColumn.Clear
ws.Columns(3).EntireColumn.Clear
ws.Columns(4).EntireColumn.Clear
ws.Columns(5).EntireColumn.Clear
ws.Columns(6).EntireColumn.Clear
ws.Columns(7).EntireColumn.Clear
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("C:\Users\king_matthew\Documents\ELINV 2018")
filecountB = objFolder.Files.Count
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
ws.Cells(i + 1, 2) = objFile.Name
'print file path
ws.Cells(i + 1, 3).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=objFile.Path, TextToDisplay:=objFile.Path
'Get the file extension
FileExt = Right(objFile.Name, Len(objFile.Name) - InStrRev(objFile.Name, "."))
'Paste file extension in column D
ws.Cells(i + 1, 4) = FileExt
If FileExt = "xlsm" Then
'This line stops the excel documents opening on your screen they just open in the background meaning your screen does not flicker
Application.ScreenUpdating = False
Application.StatusBar = True
Application.StatusBar = "Currently processing item " + i + " out of " + filecountB
'This opens the documents
Workbooks.Open Filename:=objFile.Path
'Tells VBA what you are looking for
Text = "Total Invoice Value"
'Find text, defined in line above
Set Match = ActiveSheet.Cells.Find(Text)
'Get the value of the cell next to cell found above
findoffset = Match.Offset(, 1).Value
'Paste this value in to column F
ws.Cells(i + 1, 6) = findoffset
'Tells VBA what else to look for
Text2 = "Order No:"
'Find Text2, defined in line above
Set Index = ActiveSheet.Cells.Find(Text2)
'If "Order No:" cant be found then do below if it is found skip to ELSE
If Index Is Nothing Then
'Tells VBA what else to look for
Text3 = "Date:"
'Find text, defined in line above
Set Match2 = ActiveSheet.Cells.Find(Text3)
'Get the value of the cell next to cell found above
findoffset = Match2.Offset(, 1).Value
'Close the workbook
ActiveWorkbook.Close
'Turn screen updating on so that you can see the values being updated
Application.ScreenUpdating = True
'Paste this value in to column F
ws.Cells(i + 1, 5) = findoffset
'Go onto the next file
i = i + 1
Else
'Paste the "Order No:" in column G
ws.Cells(i + 1, 7) = Index
'Tells VBA what else to look for
Text3 = "Date:"
'Find text, defined in line above
Set Match2 = ActiveSheet.Cells.Find(Text3)
'Get the value of the cell next to cell found above
findoffset = Match2.Offset(, 1).Value
'Close the workbook
ActiveWorkbook.Close
'Paste this value in to column F
ws.Cells(i + 1, 5) = findoffset
'Go onto the next file
i = i + 1
End If
Else
'If file extension is anything other than XLSM then leave the date blank
ws.Cells(i + 1, 5) = ""
'Go onto the next file
i = i + 1
End If
Next objFile
'Turn screen updating on so that you can see the values being updated
Application.ScreenUpdating = True
Application.StatusBar = False
Call FindingLastRow
End Sub
Sub FindingLastRow()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lastRow As Long
Set ws = Worksheets("Admin2")
'Rows.count returns the last row of the worksheet (which in Excel 2007 is 1,048,576); Cells(Rows.count, "A")
'returns the cell A1048576, ie. last cell in column A, and the code starts from this cell moving upwards;
'the code is bascially executing Range("A1048576").End(xlUp), and Range("A1048576").End(xlUp).Row finally returns the last row number.
lastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row
ws.Range("Row_Number").Value = lastRow
End Sub
Alright, so I changed a few things and removed some unnecessary code. Here is my "changelog":
Commented out call to FindingLastRow as it currently does nothing
Moved the 'Dims' around so that they are easier to read
Removed unused variables
Added variables for the temporary workbooks
I did this to avoid using ActiveSheet which will slow code down
NOTE: The line that sets wsTemp might not work correctly, let me know if it fails
Grouped the columns.clear calls you made
Changed starting value of i to 2 for simplicity
Added range variables to catch the Range.Find("..") results
Moved Application.ScreenUpdating call outside of loop
No reason to have it toggle so frequently inside of the loop itself
Added toggle to .Calculation and .EnableEvents to potentially speed program up further
They act similarly to .ScreenUpdating by suppressing excel and speed up by focusing on only certain operations
Removed the .select for the hyperlinks
Like calling Activesheet, calling .select will also slow code down
String concatenation for StatusBar uses & instead of +
Changed around how the if statements were used to clear out duplicate code
A couple times you were repeating code in the ifs when you can just do it right after them
Re-ordered the value pasting to match the columns theyre pasted in (ie C,D,E,F,G )
When calling cells using .cells(r,c) you can actually just use the column string, so I did that for simplicity
NOTE: your comments said that 'Date' would go in column F but your actual code put it in column E, so I chose to use E
Started using .value2 and .value when accessing/pasting text into cells
NOTE: added offset to the "order no" to match your other searches (it looked like an oversight)
I think that's it???
With all that in mind, here is the result. Hopefully it scales properly with your folder now :)
Sub Invoice_Records()
Dim ws As Worksheet
Set ws = Worksheets("Admin2")
Dim wbTemp As Workbook
Dim wsTemp As Worksheet
'Create an instance of the FileSystemObject
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Dim objFolder As Object
Set objFolder = objFSO.GetFolder("C:\Users\king_matthew\Documents\ELINV 2018")
Dim objFile As Object
Dim i As Long
i = 2
Dim FileExtension As String
Dim filecountB As String
filecountB = objFolder.Files.count
Dim searchInvValue As Range
Dim searchOrderNum As Range
Dim searchDate As Range
'Toggling screen updating prevents screen flicker and speeds up operations
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
.StatusBar = True
End With
'This part clears all columns, otherwise if you were on line 10 last time you ran the code,
'and then you deleted a commercial invoice it would only update up to line 9 but the legacy values of line 10 would still show
ws.Columns("B:G").EntireColumn.Clear
'Loops through each file in the directory
For Each objFile In objFolder.Files
'Update status bar to show progress
Application.StatusBar = "Currently processing item " & (i - 1) & " out of " & filecountB
'Paste file name
ws.Cells(i, "B").Value2 = objFile.Name
'Paste file path and add a hyperlink to it
ws.Hyperlinks.Add Anchor:=ws.Cells(i, "C"), Address:=objFile.path, TextToDisplay:=objFile.path
'Get the file extension
FileExtension = UCase$(Right(objFile.Name, Len(objFile.Name) - InStrRev(objFile.Name, ".")))
'Paste file extension
ws.Cells(i, "D").Value2 = FileExtension
'Only do operations on files with the extension "xlsm", otherwise skip
If FileExtension = "xlsm" Then
'This opens the current "objFile" document
Set wbTemp = Workbooks.Open(Filename:=objFile.path)
Set wsTemp = wbTemp.Sheets(1)
'Find and paste "Date:"
Set searchDate = wsTemp.Cells.Find("Date:")
ws.Cells(i, "E").value = searchDate.Offset(, 1).value
'Find and paste "Total Invoice Value"
Set searchInvValue = wsTemp.Cells.Find("Total Invoice Value")
ws.Cells(i, "F").Value2 = searchInvValue.Offset(, 1).Value2
'Find "Order No:" and paste if not blank
Set searchOrderNum = wsTemp.Cells.Find("Order No:")
If Not searchOrderNum Is Nothing Then ws.Cells(i, "G").Value2 = searchOrderNum.Offset(, 1).Value2
'Close the current "objFile" workbook
wbTemp.Close
End If
'Go onto the next file
i = i + 1
Next objFile
'Turn screen updating back on so that you can see the values being updated
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.StatusBar = False
End With
'Call FindingLastRow 'this does not currently seem necessary
End Sub
I am trying to highligh new excel the same way as old excel and data is large .So I saved the data in range and tried to do find, count if functions in range .But it keep showing "object not find error".I really don't get it since I defined the range object well. Here are part of my codes .I tried to debug by "RangSe1(1, 1).Activate" after I defined the RangSe1 object and it give me the 424 error even from here . I am really confused .
Sub Morningsmall()
Dim strfile As String
Dim iLastrow, iColor, iFind, iLastrow1, iLastrow2, iLastrow3, iLastrow4, iRow As Long
Dim RangSe1, RangSo1, RangSe2, RangSo2, RangS As Range
Dim wbLastday, wbToday As Workbook
Dim wsSettle1, wsSettle2, wsSophis1, wsSophis2 As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculate
.Calculation = xlCalculationManual
.DisplayStatusBar = False
End With
'Open yesterday's file
MsgBox "Open Yesterday's Settlement Report"
strfile = Application.GetOpenFilename
If strfile <> "False" Then Workbooks.Open strfile
Set wbLastday = ActiveWorkbook
Set wsSettle1 = wbLastday.Sheets("SettlementReport")
Set wsSophis1 = wbLastday.Sheets("Sophis")
iLastrow1 = wsSettle1.Cells(wsSettle1.Rows.Count, 1).End(xlUp).Row
iLastrow2 = wsSophis1.Cells(wsSophis1.Rows.Count, 1).End(xlUp).Row
RangSe1 = wsSettle1.Range("A1:AQ" & iLastrow1)
RangSo1 = wsSophis1.Range("A1:AJ" & iLastrow2)
RangSe1(1, 1).Activate
...
...
...
For i = 2 To iLastrow3
iFind = RangSe2(i, 1)
'a = Application.WorksheetFunction.CountIf(Rang, iFind)
If Application.WorksheetFunction.CountIf(wsSettle1, iFind) > 0 Then
'range1.Find("test id", LookIn:=xlValues)
If RangSe1(wsSettle1.Cells.Find(what:=iFind).Row, 6) = RangSe2(i, 6) Then
iColor = RangSe1.Find(what:=iFind).Interior.Color
If iColor <> 16777215 Then
wsSettle2.Rows(i).Interior.Color = iColor
End If
End If
End If
...
...
...
Your lines saying
Dim RangSe1
'...
RangSe1 = wsSettle1.Range("A1:AQ" & iLastrow1)
is equivalent to
Dim RangSe1 As Variant
'...
RangSe1 = wsSettle1.Range("A1:AQ" & iLastrow1).Value
which will create a Variant array dimensioned as 1 To iLastrow1, 1 To 43. You can't use an Activate method on the (1, 1)th position of an array, because an array is not an object and therefore does not have methods or properties.
You have two major mistakes that are causing your code to not do what you expect:
1) You are not defining your variables correctly because:
Dim RangSe1, RangSo1, RangSe2, RangSo2, RangS As Range
is equivalent to :
Dim RangSe1 As Variant, RangSo1 As Variant, RangSe2 As Variant, RangSo2 As Variant, RangS As Range
You should use:
Dim RangSe1 As Range, RangSo1 As Range, RangSe2 As Range, RangSo2 As Range, RangS As Range
2) You are not using the Set keyword when assigning a reference to your Range objects so, for instance,
RangSe1 = wsSettle1.Range("A1:AQ" & iLastrow1)
should be
Set RangSe1 = wsSettle1.Range("A1:AQ" & iLastrow1)
I have 100+ files in one folder. Each file has 3 lists, but only 1 list with data. I need to take that data from each file and combine it in a single file on 1 list. I wrote a sub for it, but I'm not sure how to go around selecting only the range needed (it varies from file to file) - in the same way you do it on keyboard with Ctrl + Shift + left arrow + down arrow. And how should I go around pasting it in the result workbook at exactly the first free line after the data that was pasted before?
Sub combine()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim ExcelApp As Object
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = False
ExcelApp.ScreenUpdating = False
ExcelApp.DisplayAlerts = False
ExcelApp.EnableEvents = False
'**VARIABLES**
Dim folderPath As String
folderPath = "Y:\plan_graphs\final\mich_alco_test\files\"
'COUNT THE FILES
Dim totalFiles As Long
totalFiles = 0
Dim fileTitle As String
fileTitle = Dir(folderPath & "*.xl??")
Do While fileTitle <> ""
totalFiles = totalFiles + 1
fileTitle = Dir()
Loop
'OPENING FILES
Dim resultWorkbook As Workbook
Dim dataWorkbook As Workbook
Set resultWorkbook = ExcelApp.Application.Workbooks.Open("Y:\plan_graphs\final\mich_alco_test\result.xlsx")
fileTitle = Dir(folderPath & "*.xl??")
'FOR EACH FILE
Do While fileTitle <> ""
Set dataWorkbook = ExcelApp.Application.Workbooks.Open(folderPath & fileTitle)
dataWorkbook.Worksheets("List1").Range("A1").Select
dataWorkbook.Worksheets("List1").Selection.CurrentRegion.Select
`resultWorkbook.Range
fileTitle = Dir()
Loop
ExcelApp.Quit
Set ExcelApp = Nothing
End Sub
I may have misunderstood the question and unfortunately I cannot make a comment. If I've grasped this question wrong, i'll delete.
but I'm not sure how to go around selecting only the range needed
This suggests that you have a dynamic amount of data and want to use Range to grab the selections.
Supposing you know the column location of where said data is located (in this case my list starts at B2 and we don't know where it ends. You can use Range to dynamically select all data:
Dim rcell As Range
Dim rng As Range
Set rng = ActiveSheet.Range("B2", Range("B2").End(xlDown))
For Each rcell In rng.Cells
Debug.Print rcell.Value
Next rcell
End Sub
First we define a Range variable and assign it to the range starting at B2 and using .End(xlDown) we can select a range ending at the final entry.
For further reading on .End() see here.
Hope this helps.
You can do this without VBA. Use Get & Transform instead.
Here are a few steps to get you started:
Go to the Data Tab
Under Get & Transform, pick New Query - From File - From Folder
Select the folder containing all your 100+ files
Select the tab that contains your data
You are almost there. Do your final fixes (if needed)
Once you're done, click Close & Load
This should do what you want.
https://www.rondebruin.nl/win/addins/rdbmerge.htm
i have this Code VBA, its works, i can combine some files on one sheet.
check it!
Sub Open_Files()
Dim Hoja As Object
Application.ScreenUpdating = False
'Definir la variable como tipo Variante
Dim X As Variant
'Abrir cuadro de dialogo
X = Application.GetOpenFilename _
("Excel Files (*.xlsx), *.xlsx", 2, "Abrir archivos", , True)
'Validar si se seleccionaron archivos
If IsArray(X) Then ' Si se seleccionan
'Crea Libro nuevo
Workbooks.Add
'Captura nombre de archivo destino donde se grabaran los archivos seleccionados
A = ActiveWorkbook.Name
'*/********************
For y = LBound(X) To UBound(X)
Application.StatusBar = "Importando Archivos: " & X(y)
Workbooks.Open X(y)
b = ActiveWorkbook.Name
For Each Hoja In ActiveWorkbook.Sheets
Hoja.Copy after:=Workbooks(A).Sheets(Workbooks(A).Sheets.Count)
Next
Workbooks(b).Close False
Next
Application.StatusBar = "Listo"
Call Unir_Hojas
End If
Application.ScreenUpdating = False
End Sub
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
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 :/