hi,
i am out of my depth here. I cold really use some help.
I have cobbled together a macro that (should) look through a column, create new sheets based on the values in that column, copy the sheets to a new workbook with a name chosen by the user, then delete the new sheets on the original.
Each bit of code wotks individually, and I just need to add this code which creates the sheets from the column. It works fine in its own, from both the editor and from the sheet via a button, but when i add it to the rest of the script, i get this runtime out of range error on the constant 'sname'.
I cant understand why it works from the same module with the same sheet in the same workbook when its on its own, but not as part of a larger macro.
(i have tried calleing it, that doesnt work either.)
can anyone see the problem? Much appreciated in advance if you can!
This is the code section....
This is the whole thing with the above slotted in
i am out of my depth here. I cold really use some help.
I have cobbled together a macro that (should) look through a column, create new sheets based on the values in that column, copy the sheets to a new workbook with a name chosen by the user, then delete the new sheets on the original.
Each bit of code wotks individually, and I just need to add this code which creates the sheets from the column. It works fine in its own, from both the editor and from the sheet via a button, but when i add it to the rest of the script, i get this runtime out of range error on the constant 'sname'.
I cant understand why it works from the same module with the same sheet in the same workbook when its on its own, but not as part of a larger macro.
(i have tried calleing it, that doesnt work either.)
can anyone see the problem? Much appreciated in advance if you can!
This is the code section....
Code:
Const sname As String = "CCRead" 'change to whatever starting sheetConst s As String = "M" 'change to whatever criterion column
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With Sheets(sname)
rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
cc = .Columns(s).Column
End With
For Each sh In Worksheets
d(sh.Name) = 1
Next sh
Application.ScreenUpdating = False
With Sheets.Add(after:=Sheets(sname))
Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
a = .Cells(cc).Resize(rws + 1, 1)
p = 2
For i = 2 To rws + 1
If a(i, 1) <> a(p, 1) Then
If d(a(p, 1)) <> 1 Then
Sheets.Add.Name = a(p, 1)
.Cells(1).Resize(, cls).Copy Cells(1)
.Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
End If
p = i
End If
Next i
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
Sheets(sname).ActivateThis is the whole thing with the above slotted in
Code:
Sub NewNamedWorkbook()
Dim NewName As String
Dim Swb As Workbook
If MsgBox("Filter range to a new workbook?" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
With Application
retry:
' Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook")
'-------------------------------------------------------------------------------------------
If StrPtr(NewName) = 0 Then
MsgBox ("User canceled!")
GoTo reset
Else
'MsgBox ("User entered " & NewName)
End If
'------------------------------------------------------------------------------------------
'VBA Check if File Exists
Dim strFile As String
strFile = ThisWorkbook.Path & "\" & NewName & ".xlsx"
'MsgBox "Files would be saved as: " & ThisWorkbook.Path & "\" & NewName & ".xlsx"
If FileExists(strFile) Then
'File Exists
MsgBox "The filename you have chosen already exists, please choose a unique filename"
GoTo retry
Else
'File Does Not Exist
End If
'---------------------------------------------------------------------------------------------
End With
Set NewBook = Workbooks.Add
With NewBook
.title = NewName 'You can modify this value.
.Subject = "Expenses In WorkSheets arranged by Cost Centre or Task Code" 'You can modify this value.
' Save it with the NewName and in the same directory as the tool
.SaveAs ThisWorkbook.Path & "\" & NewName & ".xlsx"
End With
'code here to filter and copy to the named workbook -----------------------------------------------------------------------------------
Const sname As String = "CCRead" 'change to whatever starting sheet
Const s As String = "M" 'change to whatever criterion column
Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set d = CreateObject("scripting.dictionary")
With Sheets(sname) '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< error here!!!
rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
cc = .Columns(s).Column
End With
For Each sh In Worksheets
d(sh.Name) = 1
Next sh
Application.ScreenUpdating = False
With Sheets.Add(after:=Sheets(sname))
Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
a = .Cells(cc).Resize(rws + 1, 1)
p = 2
For i = 2 To rws + 1
If a(i, 1) <> a(p, 1) Then
If d(a(p, 1)) <> 1 Then
Sheets.Add.Name = a(p, 1)
.Cells(1).Resize(, cls).Copy Cells(1)
.Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
End If
p = i
End If
Next i
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
Sheets(sname).Activate
'---------------------------------------------------------------------------------------------------------------------------------------
For Each ws In ThisWorkbook.Worksheets
Select Case ws.Name
Case "Dashboard", "Expenses", "CCRead", "INVRead" 'list the sheets NOT to copy
Case Else
'copy here
With Workbooks("Expenses.xlsm")
'ws.Copy After:=.Sheets(.Sheets.Count) 'copys after last sheet
ws.Copy Before:=Workbooks(NewName & ".xlsx").Sheets(1)
End With
End Select
Next
'delete the sheets from the main workbook
For Each ws In ThisWorkbook.Worksheets
Select Case ws.Name
Case "Dashboard", "Expenses", "CCRead", "INVRead" 'list the sheets NOT to copy
Case Else
'copy here
With Workbooks("Expenses.xlsm")
'ws.Copy After:=.Sheets(.Sheets.Count) 'copys after last sheet
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End With
End Select
Next
Exit Sub
reset:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
