I have an excel worksheet that accepts input from another excel file. This excel file has structured data in which I need to separate individually as sheets. I already have the following code to copy and format that data in a certain range but I need to loop this process for the whole worksheet until there's no more data.
The range currently I set is A2:P20 the next range is 4 rows below and that would be A25:P43.
Option Explicit
Public Sub CopySheetToClosedWorkbook()
Dim fileName
Dim closedBook As Workbook
Dim currentSheet As Worksheet
fileName = Application.GetOpenFilename("Excel Files (*.xls*),*xls*")
If fileName <> False Then
Application.ScreenUpdating = False
Set currentSheet = Application.ActiveSheet
Set closedBook = Workbooks.Open(fileName)
closedBook.Sheets(1).Range("A2:P20").Copy
ThisWorkbook.Worksheets("input").Range("A2").PasteSpecial xlPasteValues
closedBook.Application.CutCopyMode = False
closedBook.Close (True)
Application.ScreenUpdating = True
CopySheetAndRenameByCell2
End If
End Sub
You could do something based on the code below. I have set the last row as 1000, you will need to derrive this from your data.
Sub SplitRangeTest()
Dim lLastRow As Long
Dim lRow As Long
Dim lRangeSize As Long
Dim lSpacerSize As Long
lRangeSize = 19
lRow = 2
lSpacerSize = 4
lLastRow = 1000 ' Get the last populated row in the column of choice here
Do Until lRow > lLastRow
Debug.Print Range("A" & lRow).Resize(lRangeSize, 16).Address
lRow = lRow + lRangeSize + lSpacerSize
Loop
End Sub
Try this:
Public Sub CopySheetToClosedWorkbook()
Dim fileName As String
Dim closedBook As Workbook
Dim currentSheet As Worksheet
fileName = Application.GetOpenFilename("Excel Files (*.xls*),*xls*")
If fileName <> False Then
start_row = 2
rows_to_copy = 19
row_step = 23
Set currentSheet = Application.ActiveSheet
Set closedBook = Workbooks.Open(fileName)
last_row = Sheets(1).Cells(Sheets(1).Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For y = start_row To last_row Step row_step
ThisWorkbook.Worksheets("input").Rows(y).Resize(rows_to_copy, 16).Value = closedBook.Sheets(1).Rows(y).Resize(rows_to_copy, 16).Value
Next
Application.ScreenUpdating = True
End If
End Sub
it's worth mentioning here that you set currentSheet but don't actually use it. Also, you shouldn't really use ThisWorkbook like that. Maybe you should be using currentSheet instead (or at least, it's parent).
Related
I have got a worksheet with some data. I store that data in an array and then I want to create a new worksheet and save the data into a new worksheet.
Right now I'm creating a new sheet in the workbook of origin data like this:
Sub New_workbook()
Dim sh as Worksheet, origin as Worksheet, arr
origin = Sheets("OriginSheet")
sh = ActiveSheet
somedata = origin.Range("A1:C").Value
ReDim arr(1 To 100, 1 To 3)
For i = 1 To 100
arr(i, 1) = somedata(i, 1)
arr(i, 2) = somedata(i, 2)
arr(i, 3) = somedata(i, 3)
Next i
sh.Range("A2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub
and instead of sh = ActiveSheet, I would like to have something like sh = NewWorkbook("Name_of_new_workbook") and create a workbook in the directory of OriginSheet workbook or given path and fill it with arr values. How can I do this in VBA?
If you are looking to copy all the data in your source range, it isn't necessary to store that data in an array first. Just Set your range and make the value of the destination range equal the value of the source range. Try something like this:
Sub CopyRangeIntoNewWorkbook()
'disabling screen update and calculation to speed things up
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wb As Workbook, wb_new As Workbook
Dim ws As Worksheet
Dim rng As Range
Set wb = ActiveWorkbook
Set ws = ActiveSheet
'set the rng for which you want to copy the values
Set rng = ws.Range("A1:C10")
'set wb_new to newly added wb
Set wb_new = Workbooks.Add()
'specify the top left cell of the range you want to have populated in the new wb
wb_new.Sheets(1).Range("A1").Resize(rng.Rows.Count, rng.Columns.Count).Value2 = rng.Value2
'save file, here using path of your original wb'
wb_new.SaveAs Filename:=wb.path & "\wb_new.xlsx"
'closing the new file
wb_new.Close saveChanges:=False
'enabling screen update and automatic calculation again
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
The most eficient way to copy a sheet content in a new workbook should be the next one:
Sub New_workbook()
Dim origin As Worksheet
Set origin = Sheets("OriginSheet") 'an object must be Set
origin.Copy 'this will create a new workbook with the content of the copied sheet
ActiveWorkbook.saveas origin.Parent.path & "\" & "Name_of_new_workbook" & ".xlsx", xlWorkbookDefault
End Sub
If needing to keep only columns "A:C", you can add the next code lines:
Dim sh As Worksheet, lastCol As Long
Set sh = ActiveWorkbook.Worksheets(1)
lastCol = sh.cells.SpecialCells(xlCellTypeLastCell).Column
If lastCol <= 3 Then Exit Sub
If lastCol = 4 Then sh.cells(1, 4).EntireColumn.Delete: Exit Sub
sh.Range(sh.cells(1, 4), sh.cells(1, lastCol)).EntireColumn.Delete
I'm new to VBA and trying to put together a macro to copy in data from another workbook and then hyperlink values on an existing sheet to the sheets i've copied in based on a string value in a cell. For the most part the script works however i'm getting a type mismatch error. Hoping someone can help identify what i'm doing wrong.
Sub CopyTitleDetailData()
'Copy all sheets from Key New Release Detail sheet, overrides existing sheets, copys in new sheets
Dim wb As Workbook, ws As Worksheet, wbTarget As Workbook, wsTarget As Worksheet
Application.ScreenUpdating = False
Set wb = ActiveWorkbook 'Main workbook
Dim pth As String
pth = wb.Path
Dim titleDetailPth As String
titleDetailPth = Left(pth, InStrRev(pth, "\") - 1)
Dim filePthName As String
filePthName = titleDetailPth & "\Files for Pre-Order Report (Macro & Alteryx)\" & "Key New Release Accounts Details.xlsx"
Set wbTarget = Workbooks.Open(filePthName, UpdateLinks = False, ReadOnly = True)
For Each wsTarget In wbTarget.Worksheets 'A loop for each worksheet in the Key New Release Detail workbook
For Each ws In wb.Worksheets 'A loop for each worksheet in the Pre-Order (i.e. active workbook)
If wsTarget.Name = ws.Name Then 'If the sheet I am importing exists, it will be deleted
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next ws
wsTarget.Copy After:=wb.Sheets(wb.Sheets.Count) 'Copies it into the last sheet
wb.Sheets(wsTarget.Name).Visible = 0 'Hides the copied sheets
Next wsTarget
wbTarget.Close SaveChanges:=False
Application.ScreenUpdating = True
'Loops through a specified column and when a specified value is found, puts a hyperlink in the cell below
Const cWsName As String = "Title Detail"
Const cSearch As String = "Title"
Const cRow1 As Integer = 1
Const cRow2 As Integer = 800
Const cCol As String = "D"
Dim oWb As Workbook
Dim oWs As Worksheet
Dim rCell1 As Range
Dim rCell2 As Range
Dim iR As Integer
Dim strText As String
Dim strAddr As String
Set oWb = ActiveWorkbook
Set oWs = oWb.Worksheets(cWsName)
For iR = cRow1 To cRow2
Set rCell1 = oWs.Range(cCol & iR)
Set rCell2 = oWs.Range(cCol & iR + 1)
strText = rCell2.Text 'What's written in the cell.
strAddr = rCell2.Address 'The address e.g. B1, B13 ...
If rCell1 = cSearch Then
If strText <> "" Then
'Anchor is the place where i'm placing the hyperlink.
'SubAddress is where the hyperlink will take you
rCell2.Hyperlinks.Add _
Anchor:=rCell2, _
Address:="", _
SubAddress:="'" & rCell2 & "'!" & "A1", _
TextToDisplay:=strText 'The same text that orginally lived in the cell
Else
'What im doing if the cell is empty (i.e. nothing)
End If
End If
Next
Dim beginRow As Long
Dim endRow As Long
Dim chkCol As Long
Dim rowCnt As Long
Dim rngResult As Range
beginRow = 1
endRow = 800
chkCol = 1
With oWs
.Cells.EntireRow.Hidden = False 'Unhides all rows, remove line if that's not desired
For rowCnt = beginRow To endRow
If .Cells(rowCnt, chkCol) = "X" Then
If rngResult Is Nothing Then
Set rngResult = .Cells(rowCnt, 1)
Else
Set rngResult = Union(rngResult, .Cells(rowCnt, 1))
End If
End If
Next rowCnt
End With
If Not rngResult Is Nothing Then rngResult.EntireRow.Hidden = True
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim oWs As Workbook
Dim targetString As String, targetSheet As Worksheet
Set oWs = ActiveWorkbook
targetString = Cells(Target.Range.Row, Target.Range.Column).Value
Set targetSheet = oWs.Sheets(targetString)
If targetSheet.Visible = False Then
targetSheet.Visible = True
End If
'End on Title Detail Sheet
targetSheet.Select
End Sub
Per this documentation, you have to provide an Address when adding a hyperlink. you seem to be setting Address = ""
https://learn.microsoft.com/en-us/office/vba/api/excel.hyperlinks.add
I'm trying to get a spreadsheet that will import data from another file, scan the file for certain values in column D and then paste specific cells (not the whole row) into the first row that has a blank cell in column F in the new spreadsheet.
This is my updated code now
Sub GetAmazonData()
Dim counter As Integer
Dim LastRow As Long
Dim Adspend As Workbook
Dim A As String
Dim Amazon As Workbook
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Set Adspend = ActiveWorkbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Specify data export file
A = Application.GetOpenFilename(Title:="Select File To Be Processed")
Set Amazon = Application.Workbooks.Open(A)
counter = 2
' While Not Amazon.Worksheets(1).Range("D" & counter) = ""
If Amazon.Worksheets(1).Range("D" & counter) = "B01GB3HZ34" Then
Set targetSheet = Adspend.Worksheets("DirtyDom")
Set sourceSheet = Amazon.Worksheets(1)
LastRow = Adspend.Worksheets("DirtyDom").Cells(Adspend.Worksheets("DirtyDom").Rows.Count, "F").End(xlUp).Row
targetSheet.Range("F" & LastRow).Value = sourceSheet.Range("D" & counter).Value
Else
LastRow = Adspend.Worksheets("DirtyDom").Cells(Adspend.Worksheets("DirtyDom").Rows.Count, "F").End(xlUp).Row
targetSheet.Range("F" & LastRow).Value = sourceSheet.Range("D4").Value
End If
' ActiveCell.Offset(1, 0).Active
' Wend
Amazon.Close
End Sub
I expect this bit of code to paste what is in the imported file's first sheet cell D1 into the sheet called DirtyDom in cell F1 since 1 is the first cell blank in column F.
I get the error Object variable or With block variable not set.
Thank you!
Try something like this, it also puts your loop back in and resets your screen updating and alerts - untested.
Sub GetAmazonData()
Dim Adspend As Workbook
Dim Amazon As Workbook
Dim Targetsheet As Worksheet
Dim Amazonsheet As Worksheet
Dim Amazonfilename As String
Dim lastAmazonrow As Long
Dim lastTargetrow As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Adspend = ActiveWorkbook
Set Targetsheet = Adspend.Worksheets("DirtyDom")
'Specify data export file
Amazonfilename = Application.GetOpenFilename(Title:="Select File To Be Processed")
Set Amazon = Application.Workbooks.Open(Amazonfilename)
Set Amazonsheet = Amazon.Worksheets(1)
lastAmazonrow = Amazonsheet.Cells(Amazonsheet.Rows.Count, "D").End(xlUp).Row
lastTargetrow = Targetsheet.Cells(Targetsheet.Rows.Count, "F").End(xlUp).Row + 1
For counter = 1 To lastAmazonrow
If Amazonsheet.Range("D" & counter) = "B01GB3HZ34" Then
Targetsheet.Range("F" & lastTargetrow).Value = Amazonsheet.Range("D" & counter).Value
Else
Targetsheet.Range("F" & lastTargetrow).Value = Amazonsheet.Range("D4").Value
End If
lastTargetrow = lastTargetrow + 1
Next i
Amazon.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Long time reader and admirer of StackOverflow.
Basically I am trying to to loop through a series of Excel files to copy a range of data and paste it on a single Excel workbook/sheet.
The cell range location (C3:D8, D3:E8) is not always consistent, but the table dimensions are: 29 R x 2 C. Also, the files only have 1 sheet, and aside from the table dimensions specified, no data values in other cells.
In its current form the code is executing, but not pasting anything to its destination Excel file.
I need it to
Find the data dimension in file (table)
Copy the table
Paste to destination (below previous table)
Loop through to next file
Repeat Step 1-4
The code is from:
Excel VBA: automating copying ranges from different workbooks into one final destination sheet?
Thanks a lot for any help, I really appreciate it and please feel tell me to specify anything if my question is vague.
Sub SourcetoDest()
Dim wbDest As Workbook
Dim wbSource As Workbook
Dim sDestPath As String
Dim sSourcePath As String
Dim shDest As Worksheet
Dim rDest As Range
Dim vaFiles As Variant
Dim i As Long
'array of folder names under sDestPath
'array of file names under vaFiles
vaFiles = Array("Book1.xls")
sDestPath = "C:\Users"
sSourcePath = "C:\Users"
Set wbDest = Workbooks.Open(sDestPath & "\" & "Book2.xlsm")
Set shDest = wbDest.Sheets(1)
'loop through the files
For i = LBound(vaFiles) To UBound(vaFiles)
'open the source
Set wbSource = Workbooks.Open(sSourcePath & "\" & vaFiles(i))
'find the next cell in col C
Set rDest = shDest.Cells(shDest.Rows.Count, 3).End(xlUp).Offset(1, 0)
'write the values from source into destination
rDest.Resize(5, 1).Value = wbSource.Sheets(1).Range("C7:D33").Value
wbSource.Close False
Next i
End Sub
The below should achieve what you're after.
Option Explicit
Sub copy_rng()
Dim wb As Workbook, wbDest As Workbook, ws As Worksheet, wsDest As Worksheet, wsSrc As Worksheet
Dim wbNames() As Variant
Dim destFirstCell As Range
Dim destColStart As Integer, destRowStart As Long, i As Byte
Dim destPath As String
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1") ' Amend to your sheet name
Set wsSrc = wb.Sheets("Sheet2") ' Amend to sheet name with table data
wbNames = ws.Range("A2:A" & lrow(1, ws)) ' Pass col number into lrow function
destPath = "C:\Users\"
Application.ScreenUpdating = False
For i = 1 To UBound(wbNames, 1)
Set wbDest = Workbooks.Open(destPath & wbNames(i, 1))
Set wsDest = wbDest.Worksheets(1)
With wsDest
Set destFirstCell = .Cells.Find(What:="*")
destColStart = destFirstCell.Column
destRowStart = destFirstCell.Row
.Range(Cells(destRowStart, destColStart), _
Cells(lrow(destColStart, wsDest), icol(destRowStart, wsDest))).Copy
End With
wsSrc.Cells(lrow(1, wsSrc) + 1, 1).PasteSpecial Paste:=xlPasteAll
wbDest.Close False
Next i
Application.ScreenUpdating = True
End Sub
Function lrow(ByVal col_num As Integer, sheet_name As Worksheet) As Long
lrow = sheet_name.Cells(Rows.Count, col_num).End(xlUp).Row
End Function
Function icol(ByVal row_num As Long, sheet_name As Worksheet) As Integer
icol = sheet_name.Cells(row_num, Columns.Count).End(xlToLeft).Column
End Function
Ensure you copy both of the functions across, they're used to create the dimensions of the table, and then copying the table.
You will need to amend the sheet name variables. Let me know if you have any questions.
You need to amend the range of where the workbook names are stored. You need to pass the column number in, so that the last row can be calculated. You can also amend the column in which data is pasted back into the workbook.
With the help of this code you can copy all workbooks and worksheets data
into one workbook
Sub copydata()
Dim fso As Scripting.FileSystemObject
Dim fill As Scripting.File
Dim oldfolder As String
Dim newfolder As String
Dim subfolder As Folder
Dim myfolder As Folder
Dim fd As FileDialog
Dim loopcount As Integer
Dim wb
Dim wb2 As Workbook
Dim rr As Range
Set fso = New Scripting.FileSystemObject
Set wb = ThisWorkbook
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "Please Select Folder to copy"
fd.ButtonName = "Go!"
fd.Show
oldfolder = fd.SelectedItems(1)
Set myfolder = fso.GetFolder(oldfolder)
'Application.ScreenUpdating = False
Application.EnableEvents = False
For Each subfolder In myfolder.SubFolders
For Each fill In subfolder.Files
If fill Like "*.xlsm" Or fill Like "*.xlsx" Or fill Like ".*xls" Then
'fill.Range("A1:Z100").Copy
Set wb2 = Application.Workbooks.Open(fill,0 , True)
wb2.Activate
For loopcount = 1 To wb2.Worksheets.Count
wb2.Activate
Worksheets(loopcount).Activate
Range("A1:Z300").Copy 'Replace your range
wb.Activate
Sheet1.Activate
Set rr = Range("A:A").Find("", Range("A1"))
rr.Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select
Next loopcount
wb2.Close False
End If
Application.CutCopyMode = False
Debug.Print fill.Name
Next fill
Next subfolder
MsgBox "Done"
For Each fill In myfolder.Files
Application.DisplayAlerts = False
If fill Like "*.xlsm" Or fill Like "*.xlsx" Or fill Like ".*xls" Or fill Like "*.xlsb" Then
'fill.Range("A1:Z100").Copy
Set wb2 = Application.Workbooks.Open(fill, 0, True)
wb2.Activate
For loopcount = 1 To wb2.Worksheets.Count
wb2.Activate
Worksheets(loopcount).Activate
Range("A:Z").EntireColumn.Hidden = False
Range("A1:Z1").AutoFilter
Range("A1:Z300").Copy
wb.Activate
Sheet1.Activate
Set rr = Range("A:A").Find("", Range("A1"))
rr.Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select
Next loopcount
wb2.Close False
End If
Application.CutCopyMode = False
Debug.Print fill.Name
Next fill
Application.EnableEvents = True
End Sub
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