Subscript Out of Range Error in Code - vba

I have a macro that moves data from a master sheet to their respective sheets in a workbook by group and then creates a separate workbook of each of those sheets... But I have been getting an error and don't remember having changed anything on it. Can someone let me know what is wrong and how to fix it?
Subscript out of range error in line starting with Activeworkbook.SaveAs...
Sub transfer_data()
Application.ScreenUpdating = False
Dim filter_criteria As String
Dim bridge_rows As Integer
Dim rng As Range
Dim rng2 As Range
Dim dest_num_rows As Integer
bridge_rows = Worksheets("Bridge").Range("A1").CurrentRegion.Rows.Count
Set rng = Worksheets("Master").Range("A6").CurrentRegion
For n = 3 To bridge_rows + 1
filter_criteria = Application.WorksheetFunction.Index(Worksheets("Bridge").Range("A1:B" & bridge_rows), Application.WorksheetFunction.Match(Worksheets(n).Name, Worksheets("Bridge").Range("B1:B" & bridge_rows), 0), 1)
dest_num_rows = Worksheets(n).Range("A1").CurrentRegion.Rows.Count
rng.AutoFilter Field:=7, Criteria1:=filter_criteria
Set rng2 = rng.Offset(1, 0).Resize(rng.Rows.Count - 1, 6)
rng2.Copy Destination:=Worksheets(n).Range("A" & dest_num_rows + 1)
Workbooks.Add
ActiveWorkbook.SaveAs Filename:="H:\BX-HR\BX-INDUSTRIAL RELATIONS\HR REPRESENTATIVES\PRIVATE\HRSSC\US&CA Benefits\Data Files\" & Workbooks("Retroactive Premiums - Semi-monthly v2.xlsm").Worksheets(n).Name, FileFormat:=xlCSV, CreateBackup:=False
ThisWorkbook.Sheets(n).Range("A1").CurrentRegion.Copy Destination:=ActiveWorkbook.Worksheets(1).Range("A1")
ActiveWorkbook.Close savechanges:=True
Next n
rng.AutoFilter
Worksheets("Master").Range("A7:A" & rng.Rows.Count + 5).Clear
Worksheets("Master").Range("D7:D" & rng.Rows.Count + 5).Clear
Application.ScreenUpdating = True
End Sub

Your error must be related to this part of the line that's giving you the error:
Workbooks("Retroactive Premiums - Semi-monthly v2.xlsm").Worksheets(n)
There are two reasons for this to give an error:
Workbooks("Retroactive Premiums - Semi-monthly v2.xlsm"): a workbook with the specified name is not currently open.
Worksheets(n): the specified workbook with that name is open but it doesn't have a sheet with the n index.

This is one main reason why one should declare variables/objects and work with them :) Things like Activeworkbook/Select etc should be avoided.
You should be use the code like this
Sub Sample()
Dim wbThis As Workbook, wbNew As Workbook
Dim sPath As String
sPath = "H:\BX-HR\BX-INDUSTRIAL RELATIONS\HR REPRESENTATIVES\PRIVATE\HRSSC\US&CA Benefits\Data Files\"
Set wbThis = ThisWorkbook '<~~ "Retroactive Premiums - Semi-monthly v2.xlsm" ???
'
'~~> Rest of the code
'
Set wbNew = Workbooks.Add
wbNew.SaveAs Filename:=sPath & wbThis.Worksheets(n).Name, FileFormat:=xlCSV, CreateBackup:=False
'
'~~> Rest of the code
'
End Sub

Related

Error 1004 on range.paste

I'm currently getting mad on a macro.
I spent hours on the internet searching for a solution, but I came to the point where I have to ask for help :(
I get a
run-time error '1004' application-defined or object-defined error
on this line: Range(rngZelle1.Offset(1, 2)).Paste
Option Explicit
Sub import()
Dim bk As Workbook
Dim sh, asheet As Worksheet
Dim rngZelle, rngZelle1 As Range
Dim strSuchwort, sDate, sPath, sName As String
Application.ScreenUpdating = False
Set sh = ActiveSheet
strSuchwort = "test"
sPath = "C:\Users\stefan.******\Downloads\" 'you dont need to know my real name :P
sName = Dir(sPath & "*.xl*")
Do While sName <> ""
Set bk = Workbooks.Open(sPath & sName)
For Each asheet In ActiveWorkbook.Worksheets
asheet.Activate
For Each rngZelle In Range("A:A")
If UCase(rngZelle) Like UCase(strSuchwort) Then
sDate = Right(rngZelle, 10)
Range(rngZelle.Offset(2, 1), rngZelle.Offset(25, 1)).copy
For Each rngZelle1 In sh.Range("A:A")
If rngZelle1 = sDate Then
Range(rngZelle1.Offset(1, 2)).Paste '<---- thats the line i get the error
End If
Next rngZelle1
End If
Next rngZelle
Next asheet
Everything goes well up to the mentioned line. I tried to replace it for test purposes by "msgbox sdate" what went well.
What I really dont get, in the previous loop the copy goes well. It seems to be all about the paste line.
I hope one of you guys can help a totally noob out :) Every help is really appreciate as I'm getting really nuts on this.
Paste is a Workbook method which can't be used on a Range object.
The corresponding Range method is PasteSpecial which takes 4 optional parameters. The Paste parameter takes an xlPasteType which is xlPasteAll by default. For clarity I usually include xlPasteType even if using the default.
If you change:
Range(rngZelle1.Offset(1, 2)).Paste
to:
Range(rngZelle1.Offset(1, 2)).PasteSpecial xlPasteAll
your code should work.
Following the comments above by #Scott Craner and #user3598756 , there a few "corrections" need to be made:
Dim sh, asheet As Worksheet means asheet As Worksheet and sh As Variant.
The same goes to Dim rngZelle , rngZelle1 As Range, only the second one is Range while , rngZelle As Variant.
To conclude the first section of declaration, it should be:
Dim bk As Workbook
Dim sh As Worksheet, asheet As Worksheet
Dim rngZelle As Range, rngZelle1 As Range
Dim strSuchwort As String, sDate As String, sPath As String, sName As String
Regarding the For Each asheet In ThisWorkbook.Worksheets loop:
There is no need to asheet.Activate , you can use With asheet instead.
Regarding your error, if you Copy >> Paste in 2 code lines, you need to replace the syntax of the Paste line to `PasteSpecial xlPasteAll.
For Each asheet Loop Code
For Each asheet In ThisWorkbook.Worksheets
With asheet
For Each rngZelle In .Range("A:A")
If UCase(rngZelle.Value) Like UCase(strSuchwort) Then
sDate = Right(rngZelle.Value, 10)
Range(rngZelle.Offset(2, 1), rngZelle.Offset(25, 1)).Copy
For Each rngZelle1 In sh.Range("A:A")
If rngZelle1.Value = sDate Then
rngZelle1.Offset(1, 2).PasteSpecial xlPasteAll
End If
Next rngZelle1
End If
Next rngZelle
End With
Next asheet
sorry for my late reply. Unfortunately I haven't had much time the last couple of weeks.
First of all, .PasteSpecial did the job :) thanks a lot!
Dim sh, asheet As Worksheet means asheet As Worksheet and sh As
Variant
Thank you very much for the tip, I learned something new :)
Unfortunately the with asheet and end with results in a macro what doesn't copy and paste the figures, so I stick to the loop.
I managed to build a final and working macro, but it takes 90 Minutes to run (final version shall import 5 times of current data) and it blocks the clipboard while running.
So if anyone ha any idea how to speed it up and bypass the clipboard (copy destination etc doesn't work for any reason) it would be really appreciate.
Option Explicit
Sub import()
Dim bk As Workbook
Dim sh As Worksheet, asheet As Worksheet
Dim sSkill As Range, pval As Range, lstZelle As Range, target As Range, stype As Range, lstZelle1 As Range
Dim strSuchwort As String, sDate As String, sPath As String, sName As String, strSuchwort1 As String, strSuchwort2 As String
Dim row As Integer, col As Integer
Application.ScreenUpdating = False
Set sh = ActiveSheet
sPath = "C:\Users\*******\test\"
sName = Dir(sPath & "*.xl*")
Do While sName <> ""
Set bk = Workbooks.Open(sPath & sName)
sh.Range("A1").AutoFilter field:=1, Criteria1:="<>"
For Each lstZelle In sh.Range("B:B")
If lstZelle <> "" Then
strSuchwort = lstZelle & "*"
strSuchwort2 = lstZelle.Offset(0, -1)
For Each lstZelle1 In sh.Range("C:C")
If lstZelle1 <> "" Then
strSuchwort1 = lstZelle1
For Each asheet In ActiveWorkbook.Worksheets
asheet.Activate
If asheet.Name = strSuchwort2 Then
For Each sSkill In Range("A:A")
If UCase(sSkill) Like UCase(strSuchwort) Then
sDate = Right(sSkill, 10)
For Each stype In Range(sSkill.Offset(1, 0), sSkill.Offset(1, 100))
If UCase(stype) Like UCase(strSuchwort1) Then
Range(stype.Offset(1, 0), stype.End(xlDown)).copy
For Each pval In sh.Range("1:1")
If pval = sDate Then
col = pval.Column
row = lstZelle.row
sh.Cells(row, col).PasteSpecial xlPasteValues
End If
Next pval
End If
Next stype
End If
Next sSkill
End If
Next asheet
End If
Next lstZelle1
End If
Next lstZelle
bk.Close SaveChanges:=False
sName = Dir()
Loop
Application.ScreenUpdating = True
sh.AutoFilterMode = False
End Sub

Copy 3 worksheets to new workbook - 1 with visible cells only - the other 2 with values only

I'm new here and to vba in general. I basically just read myself into the matter for my new job. So please bear with me.
I'm looking for a solution to my issue and found seperate solutions for parts but I'm not able to piece them together.
My goal is the following:
Copy 3 Worksheets of a workbook to a new one (not existing yet) and save it under the current date with a specific name.
Here's the code that I put together so far for that which works fine.
Sub export()
Dim path As String
Dim file As String
Dim ws As Worksheet
Dim rng As Range
path = "D:\#Inbox\"
file = Format(Date, "YYYY-MM-DD") & " " & Format(Time, "hhmm") & " " & "accr " & Format(DateSerial(Year(Date), Month(Date), 1), "YYYY_MM") & " city" & ".xlsx"
Application.ScreenUpdating = False
Sheets(Array("Accr", "Pivot", "Segments")).Select
Sheets(Array("Accr", "Pivot", "Segments")).Copy
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
For Each ws In Worksheets
ws.Rectangles.Delete
Next
Sheets(Array("Pivot", "Segments")).Visible = False
ActiveWorkbook.SaveAs Filename:=path & file, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
Sheets("Menu =>").Select
Range("C1").Select
End Sub
1st condition: the new workbook should not be created manually and opened first, but the macro should do that.
2nd condition: the 1st workbook should have autofilters selected and then only visible cells copied. Is that possible as a whole worksheet, or do I have to copy the cells and create a worksheet in the new workbook?
Here's the code for the filter
Sheets("Accr").Select
Reset_Filter
Selection.AutoFilter Field:=1, Criteria1:="12"
Selection.AutoFilter Field:=2, Criteria1:="booked"
Selection.AutoFilter Field:=35, Criteria1:="Frankfurt"
Set rng = Application.Intersect(ActiveSheet.UsedRange)
rng.SpecialCells(xlCellTypeVisible).Copy
3rd condition: the other two worksheets should be copied without formulas but with format. (That is included in the first code sample)
My problem is now, to piece everything together so that there are 3 worksheets in the new workbook containing in the first ws the visible cells of the source ws with the autofilter and the other two worksheets containing only the data and the format and being hidden.
Info to my reasoning: the first worksheet refers with the formulas to the other two worksheets so that the recipients of the file have preselected fields and lists to fill out the cells.
Thank you very much in advance.
EDIT: Background Info:
The Accr sheet contains accrual informattion and has the Month information in column A. Since several years should be also able to be compared in one Pivot Table later on, the format was changed from a mere number to a date (format: MM.YYYY).
Edit
Alright, here is a different code, this copies the worksheets then removes the rows in Accr which do not meet the criteria. Be sure to make ranges absolute, put $ in front of the column and row in a formula, the vlookup you mentioned should become =VLOOKUP(R2097;Segments!$G:$Q;11;0) and this goes for any formula on the Accr sheet that references a fixed range anywhere.
Sub Export()
Dim NewWorkbook As Workbook
Dim Ws As Worksheet
Dim fPath As String, fName As String
Dim i As Long
Dim RowsToDelete As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set NewWorkbook = Workbooks.Add
fPath = "D:\#Inbox\"
fName = VBA.Format(VBA.Date, "YYYY-MM-DD") & " " & VBA.Format(VBA.Time, "hhmm") & " " & "accr " & VBA.Format(VBA.DateSerial(VBA.Year(VBA.Date), VBA.Month(VBA.Date), 1), "YYYY_MM") & " city"
NewWorkbook.SaveAs fPath & fName, xlOpenXMLWorkbook
ThisWorkbook.Worksheets(Array("Accr", "Pivot", "Segments")).Copy NewWorkbook.Worksheets(1)
For Each Ws In NewWorkbook.Worksheets
With Ws
If Not .Name = "Accr" And Not .Name = "Pivot" And Not .Name = "Segments" Then
.Delete
ElseIf Ws.Name = "Accr" Then
For i = 4 To .Cells(.Rows.Count, 1).End(xlUp).Row
If Not .Cells(i, 1) = .Cells(i, 1) = Month(ThisWorkbook.Worksheets("Mon").Cells(19, 2)) And Not .Cells(i, 2) = "booked" And Not .Cells(i, 35) = "Frankfurt" Then
If RowsToDelete Is Nothing Then
Set RowsToDelete = .Rows(i).EntireRow
Else
Set RowsToDelete = Union(RowsToDelete, .Rows(i).EntireRow)
End If
End If
Next i
If Not RowsToDelete Is Nothing Then
RowsToDelete.Delete xlUp
End If
ElseIf .Name = "Pivot" Or .Name = "Segments" Then
.Visible = xlSheetHidden
.UsedRange = Ws.UsedRange.Value
End If
End With
Next Ws
NewWorkbook.Save
NewWorkbook.Close
Application.Goto ThisWorkbook.Worksheets("Menu =>").Cells(1, 3)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
End of edit
Ok... so after fiddling around with it a while and collecting several pieces of information around this website, I finally have a solution.
The main problem, was the first criteria, which is a date field. I found out that vba has its problems when the date is not in US-Format. So I made a workaround and made a textformat date in my parameter worksheet, so that I always have the export of the sheets for the current month set in the workbook.
In my accruals-data I just had to change the format in column A to have text (e.g. '01.2016).
Plus I optimized my rawdata a little bit, so that I only have to export one additional worksheet, which will be hidden and contains only hardcopy values, so that there is no external link to my original file anymore.
Sub ACTION_Export_AbgrBerlin()
Dim Pfad As String
Dim Dateiname As String
Dim ws As Worksheet
Dim oRow As Range, rng As Range
Dim myrows As Range
' define filepath and filename
Pfad = "D:\#Inbox\"
Dateiname = Format(Date, "YYYY-MM-DD") & " " & Format(Time, "hhmm") & " " & "Abr " _
& Format(DateSerial(Year(Date), Month(Date), 1), "yyyy-mm") & " Berlin" & ".xlsx"
Application.ScreenUpdating = False
Sheets(Array("Abgr", "Masterdata MP")).Copy
' hardcopy of values
Sheets("Masterdata MP").UsedRange = Sheets("Masterdata MP").UsedRange.Value
' delete Macrobuttons and Hyperlinks
For Each ws In Worksheets
ws.Rectangles.Delete
ws.Hyperlinks.Delete
Next
' delete first 3 rows (that are placeholders for the macrobuttons in the original file)
With Sheets("Abgr")
.AutoFilterMode = False
.Rows("1:3").EntireRow.Delete
' set Autofilter matching the following criteria
.Range("A1:AO1048576").AutoFilter
'refer to parameter worksheet which contains the current date as textformat
.Range("A1:AO1048576").AutoFilter Field:=1, Criteria1:=ThisWorkbook.Worksheets("Mon").Range("E21")
.Range("A1:AO1048576").AutoFilter Field:=2, Criteria1:=Array(1, "gebucht")
.Range("A1:AO1048576").AutoFilter Field:=36, Criteria1:=Array(1, "Abgr Berlin")
End With
'delete hidden rows i.e. delete anything but the selection
With Sheets("Abgr")
Set myrows = Intersect(.Range("A:A").EntireRow, .UsedRange)
End With
For Each oRow In myrows.Columns(1).Cells
If oRow.EntireRow.Hidden Then
If rng Is Nothing Then
Set rng = oRow
Else
Set rng = Union(rng, oRow)
End If
End If
Next
If Not rng Is Nothing Then rng.EntireRow.Delete
Sheets("Masterdata MP").Visible = xlSheetHidden
Sheets("Masterdata MP").UsedRange = Sheets("Masterdata MP").UsedRange.Value
ActiveWorkbook.SaveAs Filename:=Pfad & Dateiname, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
'go back to main menu in original workbook
Sheets("Menu").Select
End Sub
Now I can create one sub for each file I have to create and then run all the subs after each other. That saves me a bunch of time.
The part with the hidden rows, I found here Delete Hidden/Invisible Rows after Autofilter Excel VBA
Thanks again #silentrevolution for your help, it gave me the pointers to get the needed result.
It's not the cleanest code and I'm sure that it can be made a bit leaner, so I would appreciate any recommendations. But for now it serves my needs.

VBA Copy row and column headers which has specific values

I am very new to Visual basic, I have an excel sheet in the following format as shown in the image below.
I need to write a VB code to create a spreadsheet in the format as shown in the image below. The model name should be printed for every country that has row and column value '1' in the excel sheet. In other words just need to print Model name and Country name that has value '1' in the spreadsheet. If the cell is empty or value '0' then we need not print the model name for that particular country.
How do I go about it? I have been watching videos to do this but to no avail.
Can anyone please tell me how to do this? Any kind of help would be greatly appreciated. thanks in advance.
Edited: The current output after using the below code is in this screenshot
This should work smoothly, it will created a new sheet at every run to display the output! ;)
Sub test_Dazzler()
Dim wB As Workbook, _
wBNeW As Workbook, _
wSSrC As Worksheet, _
wSDesT As Worksheet, _
LastRow As Long, _
LastCol As Integer, _
WrintingRow As Long, _
ModeL As String
Set wB = ThisWorkbook
Set wSSrC = wB.ActiveSheet
LastRow = wSSrC.Range("A" & wSSrC.Rows.Count).End(xlUp).Row
LastCol = wSSrC.Range("A1").End(xlToRight).Column
Set wSDesT = wB.Sheets.Add
wSDesT.Cells(1, 1) = "Model": wSDesT.Cells(1, 2) = "Countries"
With wSSrC
For i = 2 To LastRow
ModeL = .Range("A" & i).Value
For j = 2 To LastCol
If .Cells(i, j) <> 1 Then
Else
WrintingRow = wSDesT.Range("A" & wSDesT.Rows.Count).End(xlUp).Row + 1
wSDesT.Cells(WrintingRow, 1) = ModeL
wSDesT.Cells(WrintingRow, 2) = .Cells(1, j)
End If
Next j
Next i
DoEvents
WsDest.Copy
End With
Set wBNeW = ActiveWorkbook
Dim intChoice As Integer
Dim strPath As String
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogSaveAs).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog(msoFileDialogSaveAs).SelectedItems(1)
If strPath <> False Then wBNeW.SaveAs strPath
'displays the result in a message box
Call MsgBox(strPath, vbInformation, "Save Path")
End If
MsgBox "I'm done!"
End Sub

VBA Dragging down formulas (in multiple rows) to last row used

I have formulas from columns O -> X and need them drag them to last row used. Below is the current code I am using:
Dim wkb As Workbook
Dim wkbFrom As Workbook
Dim wks As Worksheet
Dim rng As Range
Dim path As String, FilePart As String
Dim TheFile
Dim loc As String
Dim Lastrow As Long
Set wkb = ThisWorkbook
loc = shPivot.Range("E11").Value
path = shPivot.Range("E12").Value
FilePart = Trim(shPivot.Range("E13").Value)
TheFile = Dir(path & "*" & FilePart & ".xls")
Set wkbFrom = Workbooks.Open(loc & path & TheFile & FilePart)
Set wks = wkbFrom.Sheets("SUPPLIER_01_00028257_KIK CUSTOM")
Set rng = wks.Range("A2:N500")
'Copies range from report generated to share drive and pastes into the current week tab of open order report
rng.Copy wkb.Sheets("Current Week").Range("A4")
With ActiveSheet
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("O4:X4").AutoFill .Range("O4:X4").Resize(Lastrow)
End With
The code Lastrow is not dragging the formulas down
You can do auto-fill like this in VBA (verified using macro recording)
Range("O1:X1").Select
Selection.AutoFill Destination:=Range("O1:X25"), Type:=xlFillDefault
Now that you have this code as a base to work with you can use any variables you like in the syntax like this:
Range("O1:X1").Select
Selection.AutoFill Destination:=Range("O1:X" & Lastrow), Type:=xlFillDefault
I used this:
Sub sum_1to10_fill()
Sheets("13").Activate
Range("EG12").Copy
Range("EG12:FT36").PasteSpecial xlPasteFormulas
End sub
...and filled up my whole label both down and right.

Excel 2003: Programmatic sort of sheet in different workbook

From the current workbook, I want to open a sheet in the source workbook, turn off any filtering that may be present, sort by one column, then another, then another. Am getting 1004 and other errors. This needs to run on 2003. Any help will be appreciated!
Dim WB As Workbook, WasWBOpen As Boolean, srcfile As String, srcpath As String,
onecol as integer, twocol as integer, thrcol as integer
srcpath = "blahblah"
srcfile = "blah.xls"
On Error Resume Next
Set WB = Workbooks(srcfile)
WasWBOpen = True
On Error GoTo 0
If WB Is Nothing Then
Set WB = Workbooks.Open(srcpath & srcfile, UpdateLinks:=False)
WasWBOpen = False
End If
'code before this opens source wkbook
lstrow = Worksheets("Sheet1").UsedRange.Row - 1 + Worksheets("Sheet1").UsedRange.Rows.Count
lstcol = Worksheets("Sheet1").UsedRange.Column - 1 + Worksheets("Sheet1").UsedRange.Columns.Count
onecol=3
twocol=5
thrcol=8
With WB.Sheets("Sheet1")
.AutoFilterMode = False
.Range("1:1").AutoFilter
'Here's where error occurs--
.Range(Cells(1, 1), Cells(lstrow, lstcol)).Sort _
Key1:=Columns(onecol), Order1:=xlAscending, _
Key2:=Columns(twocol), Order2:=xlAscending, _
Key3:=Columns(thrcol), Order3:=xlAscending, Header:=xlYes
End With
If WasWBOpen = False Then
WB.Close
End If
.Range(Cells(1, 1), Cells(lstrow, lstcol)).Sort _
is better written as:
.Range(.Cells(1, 1), .Cells(lstrow, lstcol)).Sort _
The only thing I can make a stab at is perhaps your selection does not include columns 3, 5 or 8. What are the values of lstrow and lstcol before the error?
In my experience you can only sort the active worksheet. Try adding .Activate after WB.Sheets("Sheet1").
Information about the last sort is stored against the worksheet. I sometimes suspect this is the problem rather than the sheet to be sorted not being active. But .Activate has always worked for me and so I have never investigated further.
Extra information
I had assumed it was the Sort that generated the error but it is the AutoFilter.
I can generate a 1004 error by leaving row 1 empty.
What purpose does the AutoFilter statement serve? With AutoFilterMode = False I would expect it to return Nothing. Why not delete this statement?
I am also concerned about the range you are sorting. You are subtracting the number of unused rows at the top and unused columns on the left to calculate lstrow and lstcol but then including those unused rows and columns in the sort. The result is that rows at the bottom and columns on the right would not be sorted.
If have not got any unused rows at the top and unused columns on the left, this will not matter but you need to decide which range you want to sort.
Extra information 2
This section was added after I discovered a fourth way of breaking the original code. The following code appears to be bomb-proof.
Option Explicit
Sub TestSort2()
Dim WB As Workbook, WasWBOpen As Boolean, srcfile As String, srcpath As String
Dim onecol As Integer, twocol As Integer, thrcol As Integer
' Undeclared or new variables
Dim InxWB As Long
Dim lstrow As Long
Dim lstcol As Long
Dim srcpathfile As String
' Report the name of the active workbook
Debug.Print "Original active workbook " & ActiveWorkbook.Name
' I created two workbooks named "Failed sort 1.xls" and "Failed sort 2.xls".
' Both are in the same directory. "Failed sort 1.xls" contains this macro.
' "Failed sort 2.xls" contains the data.
srcpath = Application.ActiveWorkbook.Path
srcfile = "Failed sort 2.xls"
srcpathfile = srcpath & "\" & srcfile
WasWBOpen = False
' Check the open workbook for srcfile
For InxWB = 1 To Workbooks.Count
If Workbooks(InxWB).Name = srcfile Then
' Required workbook already open
Set WB = Workbooks(InxWB)
WB.Activate ' Activate it
WasWBOpen = True
Exit For
End If
Next
If Not WasWBOpen Then
' Files was not open
If Dir(srcpathfile) <> "" Then
' File exists
' Do you need UpdateLinks:=False? If there are links
' with the sort be affected if they are not updated?
Set WB = Workbooks.Open(srcpathfile, UpdateLinks:=False)
Else
' File does not exist
Call MsgBox(srcpathfile & " does not exist", vbOKOnly)
Exit Sub
End If
End If
' WB is now the active workbook whether it was open before or not
Debug.Print "Final active workbook " & ActiveWorkbook.Name ' Confirm
With Sheets("Sheet1")
.Activate
.AutoFilterMode = False
' Get the last used row and cell of the worksheet
lstrow = Cells.SpecialCells(xlCellTypeLastCell).Row
lstcol = Cells.SpecialCells(xlCellTypeLastCell).Column
onecol = 3
twocol = 5
thrcol = 8
If onecol > lstcol Or twocol > lstcol Or thrcol > lstcol Then
Call MsgBox("The sort range does include the sort columns", vbOKOnly)
If Not WasWBOpen Then
Close
End If
Exit Sub
End If
Range(Cells(1, 1), Cells(lstrow, lstcol)).Sort _
Key1:=Columns(onecol), Order1:=xlAscending, _
Key2:=Columns(twocol), Order2:=xlAscending, _
Key3:=Columns(thrcol), Order3:=xlAscending, Header:=xlYes
End With
If Not WasWBOpen Then
Close
End If
End Sub