Excel error message"one or more named invalid references" - excel

I cannot find the named range or reference that is invalid, according to Excel. I checked my named ranges, including ranges within charts. The excel file contains a macro that creates a report that works fine when launched within the file itself. However, if I call that function from another workbook to run the report that is when I get the error message of invalid references. When going through the reports created both directly and indirectly they seem identical. Setting Application.DisplayAlerts = False does not work.
I tried using the code below from from Allen Wyatt to go through all reference and none refer to outside sheets nor contain any errors.
Sub CheckReferences()
' Check for possible missing or erroneous links in
' formulas and list possible errors in a summary sheet
Dim iSh As Integer
Dim sShName As String
Dim sht As Worksheet
Dim c, sChar As String
Dim rng As Range
Dim i As Integer, j As Integer
Dim wks As Worksheet
Dim sChr As String, addr As String
Dim sFormula As String, scVal As String
Dim lNewRow As Long
Dim vHeaders
vHeaders = Array("Sheet Name", "Cell", "Cell Value", "Formula")
'check if 'Summary' worksheet is in workbook
'and if so, delete it
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
For i = 1 To Worksheets.Count
If Worksheets(i).Name = "Summary" Then
Worksheets(i).Delete
End If
Next i
iSh = Worksheets.Count
'create a new summary sheet
Sheets.Add After:=Sheets(iSh)
Sheets(Sheets.Count).Name = "Summary"
With Sheets("Summary")
Range("A1:D1") = vHeaders
End With
lNewRow = 2
' this will not work if the sheet is protected,
' assume that sheet should not be changed; so ignore it
On Error Resume Next
For i = 1 To iSh
sShName = Worksheets(i).Name
Application.Goto Sheets(sShName).Cells(1, 1)
Set rng = Cells.SpecialCells(xlCellTypeFormulas, 23)
For Each c In rng
addr = c.Address
sFormula = c.Formula
scVal = c.Text
For j = 1 To Len(c.Formula)
sChr = Mid(c.Formula, j, 1)
If sChr = "[" Or sChr = "!" Or _
IsError(c) Then
'write values to summary sheet
With Sheets("Summary")
.Cells(lNewRow, 1) = sShName
.Cells(lNewRow, 2) = addr
.Cells(lNewRow, 3) = scVal
.Cells(lNewRow, 4) = "'" & sFormula
End With
lNewRow = lNewRow + 1
Exit For
End If
Next j
Next c
Next i
' housekeeping
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
' tidy up
Sheets("Summary").Select
Columns("A:D").EntireColumn.AutoFit
Range("A1:D1").Font.Bold = True
Range("A2").Select
End Sub

Related

Extracting a range of non-contiguous cells

Extracting a range of non-contiguous cells within number of excel files in a particular folder (data has to be pulled from either of 2 UNIQUE SHEETS)
I have the below code for pulling data (range of cells) that are non-contiguous and pasting them in a new sheet. However, the code needs to look for the data in either of the 2 sheets , namely - "summary1" or "extract1".
[Note- Only one of the two sheets would be available in each file]
I can successfully pull for one of them but if i add both of them using "On Error Resume Next" i get an error. Kindly guide me on how to resolve this!
Any suggestions or tips are much appreciate!!
Code:
Sub PIdataextraction()
Dim myFile As String, path As String
Dim erow As Long, col As Long
path = "C:\Users\New\"
myFile = Dir(path & "*.xl??")
Application.ScreenUpdating = False
Do While myFile <> ""
Workbooks.Open (path & myFile)
Windows(myFile).Activate
Set copyrange = Sheets("summary1").Range("B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16")
On Error Resume Next
Set copyrange = Sheets("extract1").Range("B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16")
Windows("MasterFile.xlsm").Activate
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
col = 1
For Each cel In copyrange
cel.Copy
Cells(erow, col).PasteSpecial xlPasteValues
col = col + 1
Next
Windows(myFile).Close savechanges:=False
myFile = Dir()
Loop
Range("A:E").EntireColumn.AutoFit
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data has been Compiled,Please Check!"
End Sub
Here's one approach which factors out the "find one of these sheets in a workbook" logic into a separate function.
Sub PIdataextraction()
Const PTH As String = "C:\Users\New\" 'use const for fixed values
Const RNG As String = "B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16"
Dim myFile As String, path As String, c As Range
Dim erow As Long, col As Long, wb As Workbook, ws As Worksheet
Application.ScreenUpdating = False
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).row
myFile = Dir(PTH & "*.xl??")
Do While myFile <> ""
Set wb = Workbooks.Open(path & myFile)
Set ws = FindFirstSheet(wb, Array("summary1", "extract1"))
If Not ws Is Nothing Then 'check we got a sheet
col = 1
For Each c In ws.Range(RNG).Cells
Sheet1.Cells(erow, col).Value = c.Value
col = col + 1
Next c
Sheet1.Cells(erow, col).Value = wb.Name '<<<<<<<<<<<<<<<<
erow = erow + 1
Else
Debug.Print "No sheet found in " & ws.Name
End If
wb.Close savechanges:=False
myFile = Dir()
Loop
Range("A:E").EntireColumn.AutoFit
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data has been Compiled,Please Check!"
End Sub
'Given a workbook `wb`, return the first sheet found from
' an array of sheet names `SheetNames`
Function FindFirstSheet(wb As Workbook, SheetNames) As Worksheet
Dim ws As Worksheet, s
For Each s In SheetNames
On Error Resume Next
Set ws = wb.Worksheets(s)
On Error GoTo 0
If Not ws Is Nothing Then Exit For
Next s
Set FindFirstSheet = ws
End Function
The following code worked for me. As usual thank you for your valuable inputs!! much appriciated
Sub PIdataextraction()
Dim myFile As String, path As String
Dim erow As Long, col As Long
Dim shtSrc As Worksheet
Dim copyrange As Range, cel As Range
path = "C:\Users\New\"
myFile = Dir(path & "*.xl??")
Application.ScreenUpdating = False
Do While myFile <> ""
Workbooks.Open (path & myFile)
Windows(myFile).Activate
On Error Resume Next
Set shtSrc = Worksheets("summary1")
If Err = 9 Then
On Error Resume Next
Set shtSrc = Worksheets("extract1")
If Err = 9 Then Exit Sub
On Error GoTo 0
End If
Set copyrange = shtSrc.Range("B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16")
Windows("MasterFile.xlsm").Activate
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
col = 1
For Each cel In copyrange
Cells(erow, col).Value = cel.Value ' Equivalent of xlPasteValues
col = col + 1
Next
Windows(myFile).Close savechanges:=False
myFile = Dir()
Loop
Range("A:E").EntireColumn.AutoFit
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data has been Compiled,Please Check!"
End Sub

How to get a cells range from cell value in excel sheet?

I want to extract a range from values in cells in excel. with this code i get a error every time, but not when i put the row and column index numbers manually. This is the code:
Sub Checker()
With Application
.DisplayAlerts = False
.EnableEvents = False
End With
Dim folderpath As String
Dim workbookname As String
Dim filepath As String
folderpath = Range("B3").Value
workbookname = Range("B6").Value
filepath = folderpath + workbookname
Workbooks.Open Filename:=filepath
Range("A1").Select
Dim last_cell As Variant
Dim last_column As Variant
Dim last_row As Variant
last_column = Range("B12").Value
last_row = Range("E12").Value
last_cell = Range("B15").Value
Dim rng As Range, cell As Range
Set rng = Range(Cells(1, 1), Cells(last_row, last_column))
For Each cell In rng
If cell.Locked = True Then
Else
cell.Value = "N/P"
End If
Next cell
With Application
.DisplayAlerts = True
.EnableEvents = True
End With
End Sub
the last column should be "13" and the last row should be "51"
but every time I get error 1004.
the problem is in the set rng
Define your row/column variables as Long and specify a workbook and worksheet for every object that is located in a worksheet.
Option Explicit
Public Sub Checker()
With Application
.DisplayAlerts = False
.EnableEvents = False
End With
Dim folderpath As String
folderpath = ThisWorkbook.Worksheets("Sheet1").Range("B3").Value
Dim workbookname As String
workbookname = ThisWorkbook.Worksheets("Sheet1").Range("B6").Value
Dim filepath As String
filepath = folderpath & workbookname 'concatenate strings with & not +
Dim OpenedWb As Workbook ' set the opened workbook as a variable so you can reference it later
Set OpenedWb = Workbooks.Open(Filename:=filepath)
Dim ws As Worksheet ' define the worksheet you want to use in that workbook
Set ws = OpenedWb.Worksheets(1) 'select your sheet by tab position or
'Set ws = OpenedWb.Worksheets("Sheet1") 'select your sheet by tab name
Dim last_column As Long
last_column = ws.Range("B12").Value
Dim last_row As Long
last_row = ws.Range("E12").Value
Dim rng As Range,
Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(last_row, last_column))
Dim cell As Range
For Each cell In rng
If Not cell.Locked = True Then
cell.Value = "N/P"
End If
Next cell
'OpenedWb.Close SaveChanges:=True 'if you want to close and save
With Application
.DisplayAlerts = True
.EnableEvents = True
End With
End Sub
Note that if you disalbe events, then make sure you use error handling to enable events in any case of error or they will be turned of until you close Excel.
For Example
Public Sub Example()
Application.EnableEvents = False
On Error Goto SAVE_EXIT
' your code here …
Application.EnableEvents = True
On Error Goto 0 ' re-enable error reporting
Exit Sub
SAVE_EXIT: ' in case of error enable events
Application.EnableEvents = True
' and show error message
If Err.Number Then
Err.Raise Err.Number
End If
End Sub

For Each two times or?

I try to get a number copied from one list in one sheet to a new created sheet in specific cell. The code first check if there already exist a sheet with this name, if not it creates a new sheet and then add it and paste in a table from another sheet. After this is done I also want a number to be filled in from the list but I dont get it to work with FOR EACH as i did with first one. I really don't know how i shall do it? Im trying to get the inum to be written in each new sheet.
`Sub Sample()
Dim ws As Worksheet
Dim Row As Long
Dim inu As Long
Dim i As Long
'~~> Set this to the relevant worksheet
Set ws = Sheets("Röd")
Set wsi = Sheets("Röd")
With ws
'~~> Find last row in Column A
Row = .Range("A" & .Rows.Count).End(xlUp).Row
With wsi
inu = .Range("B" & .Rows.Count).End(xlUp).Row
'~~> Loop through the range
For i = 3 To Row
'~~> Check if cell is not empty
If Len(Trim(.Range("A" & i).Value2)) <> 0 Then
'~~> Whatever this fuction does. I am guessing it
'~~> checks if the sheet already doesn't exist
If SheetCheck(.Range("A" & i)) = False Then
With ThisWorkbook
'~~> Add the sheet
.Sheets.Add After:=.Sheets(.Sheets.Count)
'~~> Color the tab
.Sheets(.Sheets.Count).Tab.Color = RGB(255, 0, 0)
'~~> Name the tab
.Sheets(.Sheets.Count).Name = Left(ws.Range("A" & i).Value2, 30)
Sheets("Utredningsmall").Range("A1:B22").Copy Destination:=Sheets(Sheets.Count).Range("A1")
.Sheets(.Sheets.Count).Range("B4").Value = ws.Range("A" & i).Value
Columns("A:B").AutoFit
Rows("1:25").AutoFit
For j = 3 To inu
'If Len(Trim(Range("B" & inu).Value2)) <> 0 Then
Sheets(Sheets.Count).Range("B3").Value2 = wsi.Range("B" & j).Value2
'End If
Next j
End With
End If
End If
Next i
End With
End With
End Sub`
Create Worksheets from List
Option Explicit
Sub createWorksheets()
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
Dim MyRange As Range
With wb.Worksheets("Röd").Range("A3")
Set MyRange = .Resize(.Worksheet.Cells(.Worksheet.Rows.Count, .Column) _
.End(xlUp).Row - .Row + 1)
End With
Application.ScreenUpdating = False
Dim MyCell As Range
For Each MyCell In MyRange.Cells
If Len(MyCell) > 0 Then
If Not SheetCheck(wb, MyCell.Value) Then
With wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
' Data
wb.Worksheets("Utredningsmall").Range("A1:B22").Copy _
Destination:=.Range("A1")
.Range("B3").Value = MyCell.Offset(, 1).Value
.Range("B4").Value = MyCell.Value
.Name = Left(MyCell.Value, 30)
' Formats
.Tab.Color = RGB(255, 0, 0)
.Columns("A:B").AutoFit
.Rows("1:25").AutoFit
End With
End If
End If
Next MyCell
Application.ScreenUpdating = True
End Sub
Function SheetCheck( _
wb As Workbook, _
ByVal SheetName As String) _
As Boolean
On Error Resume Next
Dim sh As Object: Set sh = wb.Sheets(SheetName)
On Error GoTo 0
SheetCheck = Not sh Is Nothing
End Function
Sub Röd()
Dim MyCell As Range, MyRange As Range
Dim ws As Worksheets
Dim inum As Range, Myinum As Range
'This Macro will create separate tabs based on a list in Distribution Tab A3, B3 down
Set MyRange = Sheets("Röd").Range("A3")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Application.DisplayAlerts = False
For Each MyCell In MyRange
If SheetCheck(MyCell) = False And MyCell <> "" Then
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Tab.Color = RGB(255, 0, 0)
Sheets(Sheets.Count).Name = Left(MyCell.Value2, 30) ' renames the new worksheet
Sheets("Utredningsmall").Range("A1:B22").Copy Destination:=Sheets(Sheets.Count).Range("A1")
Sheets(Sheets.Count).Range("B4").Value = MyCell.Value2
Sheets(Sheets.Count).Range("B3").Value = MyCell.Offset(, 1).Value
Columns("A:B").AutoFit
Rows("1:25").AutoFit
End If
Next
Application.DisplayAlerts = True
End Sub
OR
Sub Röd()
Dim MyCell As Range, MyRange As Range
Dim ws As Worksheets
Dim inum As Range, Myinum As Range
'This Macro will create separate tabs based on a list in Distribution Tab A3, B3 down
Set MyRange = Sheets("Röd").Range("A3")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Application.DisplayAlerts = False
For Each MyCell In MyRange
If SheetCheck(MyCell) = False And MyCell <> "" Then
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Tab.Color = RGB(255, 0, 0)
Sheets(Sheets.Count).Name = Left(MyCell.Value2, 30) ' renames the new worksheet
Sheets("Utredningsmall").Range("A1:B22").Copy Destination:=Sheets(Sheets.Count).Range("A1")
Sheets(Sheets.Count).Range("B4").Value = MyCell.Value2
Sheets(Sheets.Count).Range("B3").Value = MyCell.Offset(, 1).Value
Columns("A:B").AutoFit
Rows("1:25").AutoFit
End If
Next
Application.DisplayAlerts = True
End Sub
Function:
Function SheetCheck(MyCell As Range) As Boolean
Dim ws As Worksheet
SheetCheck = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name = Left(MyCell.Value, 30) Then
SheetCheck = True
End If
Next
End Function
Both these codes works now. They go through a list and create a new sheet for each cell in the list.

Why does this code not work with a named range?

I'm a VBA newbie and did not write this code, credit goes to Ron de Bruin. I'm using it to retrieve the value from whichever cells I enter into the Range - line 12, from whichever files I select. It works with cell locations but all my files have different locations for the defined names. But when I put a defined name into the range, ie. Set rng = Range("cName1") it doesn't work. So basically how would I modify it so I can put a named range in (but also works with a cell location if possible...) Thank you in advance for any help!!
Sub Summary_cells_from_Different_Workbooks_1()
Dim FileNameXls As Variant
Dim SummWks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String
ShName = "Sheet1" '<---- Change
Set Rng = Range("D4:D20") '<---- Change
'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", _
MultiSelect:=True)
If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Add a new workbook with one sheet for the Summary
Set SummWks = Workbooks.Add(1).Worksheets(1)
'The links to the first workbook will start in row 2
RwNum = 1
For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)
'copy the workbook name in column A
SummWks.Cells(RwNum, 1).Value = JustFileName
'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'", "''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"
On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet not exist in the workbook the row color will be Yellow.
SummWks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
SummWks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum
' Use AutoFit to set the column width in the new workbook
SummWks.UsedRange.Columns.AutoFit
MsgBox "The Summary is ready, save the file if you want to keep it"
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
End Sub

Split an excel file into multiple workbooks based on the contents of a column

I'm not experienced with VBA, but I think it's the only way for this to work.
I need to send a report to each sales team, but don't want to send them the information of other sales team. There are multiple sheets per workbook with different reports which all have a sales team column.
I would like all the sheets to be filtered by sales team, and create a new workbook for each team.
I appreciate any help.
I got this solution.
Just send me an email if you need this solution.
At first I got this format:
I create the following macro code
Option Explicit
Dim MainWorkBook As Workbook
Dim NewWorkBook As Workbook
Sub ExportWorksheet()
Dim Pointer As Long
Set MainWorkBook = ActiveWorkbook
Range("E2").Value = MainWorkBook.Sheets.Count
Application.ScreenUpdating = False 'enhance the performance
For Pointer = 2 To MainWorkBook.Sheets.Count
Set NewWorkBook = Workbooks.Add
MainWorkBook.Sheets(Pointer).Copy After:=NewWorkBook.Sheets(1)
Application.DisplayAlerts = False
NewWorkBook.Sheets(1).Delete
Application.DisplayAlerts = True
With NewWorkBook
.SaveAs Filename:="C:\Users\lengkgan\Desktop\Testing\" & MainWorkBook.Sheets(Pointer).Name & ".xls" 'you may change to yours
End With
NewWorkBook.Close SaveChanges:=True
Next Pointer
Application.ScreenUpdating = True
Range("D5").Value = "Export Completed"
End Sub
Following is the output
I have written a VBA(Macro) program which will work based on Input data. All you need to do is, provide input data in a column in another sheet. Macro will read the data and filter Master Sheet based on each row then it Generate new excel sheet based on find data.
enter Option Explicit
Dim personRows As Range 'Stores all of the rows found
'Split data into separate columns baed on the names defined in
'a RepList on the 'Names' sheet.
Sub SplitSalesData()
Dim wb As Workbook
Dim p As Range
Dim counter2 As Integer
Dim i As Integer
counter2 = 0
i = 0
Application.ScreenUpdating = False
' in my case i am generating new excel based on every 8 reacords from begining. You can simplyfy this logic based on your need.
For Each p In Sheets("Names").Range("RepList") ' Give the name of your input sheet and column
If i = 0 Then ' We are starting, so generate new excel in memeory.
Workbooks.Add
Set wb = ActiveWorkbook
ThisWorkbook.Activate
End If
WritePersonToWorkbook wb, p.Value
i = i + 1 ' Increment the counter reach time
If i = 8 Then ' As my need is after processing every 8 uniqe record just save the excel sheet and reset the processing
counter2 = counter2 + 1
wb.SaveAs ThisWorkbook.Path & "\salesdata_" & CStr(counter2) ' save the data at current directory location.
wb.Close
Set personRows = Nothing ' Once the process has completed for curent excelsheet, set the personRows as NULL
i = 0
End If
Next p
Application.ScreenUpdating = True
Set wb = Nothing
End Sub
'Writes all the data rows belonging to a RepList
Sub WritePersonToWorkbook(ByVal SalesWB As Workbook, _
ByVal Person As String)
Dim rw As Range
Dim firstRW As Range
For Each rw In UsedRange.Rows
If Not Not firstRW Is Nothing And Not IsNull(rw) Then
Set firstRW = rw ' WE want to add first row in each excel sheet.
End If
If Person = rw.Cells(1, 5) Then ' My filter is working based on "FeederID"
If personRows Is Nothing Then
Set personRows = firstRW
Set personRows = Union(personRows, rw)
Else
Set personRows = Union(personRows, rw)
End If
End If
Next rw
personRows.Copy SalesWB.Sheets(1).Cells(1, 1) ' Adding data in Excel sheet.
End Sub
please find below code
Sub SplitSheetDataIntoMultipleWorkbooksBasedOnSpecificColumn()
Dim objWorksheet As Excel.Worksheet
Dim nLastRow, nRow, nNextRow As Integer
Dim strColumnValue As String
Dim objDictionary As Object
Dim varColumnValues As Variant
Dim varColumnValue As Variant
Dim objExcelWorkbook As Excel.Workbook
Dim objSheet As Excel.Worksheet
Dim icol As Long
Dim l As Long
Dim headercol As Long
Dim stroutputfolder As String
stroutputfolder = "D:\Ba"
'dim str
icol = 1
headercol = 3
Set objWorksheet = ActiveSheet
nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
Set objDictionary = CreateObject("Scripting.Dictionary")
For nRow = headercol + 1 To nLastRow
'Get the specific Column
'Here my instance is "B" column
'You can change it to your case
strColumnValue = objWorksheet.Cells(nRow, icol).Value
If objDictionary.Exists(strColumnValue) = False Then
objDictionary.Add strColumnValue, 1
End If
Next
varColumnValues = objDictionary.Keys
For i = LBound(varColumnValues) To UBound(varColumnValues)
varColumnValue = varColumnValues(i)
'MsgBox (varColumnValues(i))
If Dir(stroutputfolder, vbDirectory) = vbNullString Then MkDir stroutputfolder
If CStr(varColumnValue) <> "" Then
objWorksheet.UsedRange.Offset(headercol - 1, 0).AutoFilter Field:=icol, Criteria1:=CStr(varColumnValue)
Set objExcelWorkbook = Excel.Application.Workbooks.Add
Set objSheet = objExcelWorkbook.Sheets(1)
objSheet.Name = objWorksheet.Name
objWorksheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=[A1]
'strFilename = strOutputFolder & "\" & strItem
ActiveWorkbook.SaveAs Filename:=stroutputfolder & "\" & CStr(varColumnValue) & ".xlsb", FileFormat:=50
ActiveWorkbook.Close savechanges:=False
l = l + 1
End If
Next
objWorksheet.ShowAllData
MsgBox (l & " files splitted")
End Sub

Resources