How can I save my workbook as CSV without losing UTF-8 characters?
So far, this the my code of saving workbook as CSV:
Option Explicit
Public wb As Workbook, ws As Worksheet, venture As String, intl As String, SvPath As String
Private Function chopFilesThenSave()
Dim NumOfColumns As Long
Dim RangeToCopy As Range
Dim RangeOfHeader As Range 'data (range) of header row
Dim WorkbookCounter As Integer
Dim RowsInFile 'how many rows (incl. header) in new files?
Dim p As Long
'Initialize data
Set ws = ThisWorkbook.Sheets("MixedNuts")
NumOfColumns = ws.UsedRange.Columns.Count
WorkbookCounter = 1
RowsInFile = 2000 + 1 'how many rows (incl. header in new files?
'Check if the folder provided is exist, else create one!
If Len(Dir(SvPath & "batch\", vbDirectory)) = 0 Then
MkDir SvPath & "batch\"
End If
'Copy the data of the first row (header)
Set RangeOfHeader = ws.Range(ws.Cells(1, 1), ws.Cells(1, NumOfColumns))
For p = 2 To ThisWorkbook.Sheets("Mixed").UsedRange.Rows.Count Step RowsInFile - 1
Set wb = Workbooks.Add
'Paste the header row in new file
RangeOfHeader.Copy wb.Sheets(1).Range("A1")
wb.Sheets(1).Range("A:B").NumberFormat = "#" 'set column as text
'Paste the chunk of rows for this file
Set RangeToCopy = ws.Range(ws.Cells(p, 1), ws.Cells(p + RowsInFile - 2, NumOfColumns))
RangeToCopy.Copy
wb.Sheets(1).Range("A2").PasteSpecial xlPasteValues
'Save the new workbook, and close it
wb.SaveAs SvPath & "batch\" & venture & intl & "BatchUpdate_" & Format(Now, "mmDDYYYY") & "-" & WorkbookCounter & ".csv", xlCSV
wb.Close False
'Increment file counter
WorkbookCounter = WorkbookCounter + 1
Next p
Set wb = Nothing
End Function
The code runs in a loop where I cut 2,000 rows (excluding headers) from sheet "MixedNuts", copy and paste to a new workbook then save it as CSV and do this again on the next row. But again, the problem is after saving it as CSV, utf-8 characters became question marks.
Related
I have various workbooks with different employee names containing different projectnumbers and hours worked on these projects. I'm trying to get these project numbers filtered out to a master file (zmaster) containing the entire row(s) of a specific project number. I need Excel to filter through the directory (specific folder cointaining all employee hours files) for matches and copy these matches into the zmaster file. The filter is cell A1 of the master file (eg. 300000 in linked picture example). Picture 1 is the master file and picture 2 is an example of the employee hours file.
https://i.stack.imgur.com/OKs68.png (1)
https://i.stack.imgur.com/va2Yn.png (2)
Also, it would be great if Excel would filter out duplicates (eg. week 30 with the exact same hours and employee name already in the master file is most likely duplicate and should be ignored).
I'm pretty new to Excel vba and found/adjusted the following macro's. The first one copies all data from the directory and places it into the master file. The second one filters out the projectnumber matching with cell A1. However, this requires 2 steps and when I run my first macro for the second time it will also collect data already entered into the master file. Also, my second macro places matches in the same row number as where they're placed in the employee hours file and therefore removing earlier observations in the master file placed in the same row (eg. projectnumber 100000 is placed in row 2 of the employee hours file therefore copying to row 2 in the master file, removing the indicator row of the master file).
First macro:
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String
Filepath = ("C:\test\”)
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "zmaster.xlsx" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
Range("A2:L9").Copy
ActiveWorkbook.Close
erow = Blad1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range(Cells(erow, 1), Cells(erow, 4))
MyFile = Dir
Loop
End Sub
Second macro:
Sub finddata()
Dim projectnumber As Integer
Dim finalrow As Integer
Dim i As Integer
Sheets("Blad1").Range("A1:H9").ClearContents
projectnumber = Sheets("Blad1").Range("A1").Value
finalrow = Sheets("Blad1").Range("A30").End(x1Up).row
For i = 1 To finalrow
If Cells(i, 1) = projectnumber Then
Range(Cells(i, 1), Cells(i, 12)).Copy
Range("A100").End(x1Up).Offset(1, 0).PasteSpecial x1pasteformulasandnumberformats
End If
Next i
Range("A1").Select
End sub
Hopefully everything is clear and thanks in advance!
This should work.
Open each file in directory
check that the file name is not zmaster and that it contains xlsx
run through each row in the current file and then combine the range for copying to master file
copy to master file last row plus 1, which is the first empty row
Option Explicit
Sub CopyToMasterFile()
Dim MasterWB As Workbook
Dim MasterSht As Worksheet
Dim MasterWBShtLstRw As Long
Dim FolderPath As String
Dim TempFile
Dim CurrentWB As Workbook
Dim CurrentWBSht As Worksheet
Dim CurrentShtLstRw As Long
Dim CurrentShtRowRef As Long
Dim CopyRange As Range
Dim ProjectNumber As String
FolderPath = "C:\test\"
TempFile = Dir(FolderPath)
Dim WkBk As Workbook
Dim WkBkIsOpen As Boolean
'Check is zmaster is open already
For Each WkBk In Workbooks
If WkBk.Name = "zmaster.xlsx" Then WkBkIsOpen = True
Next WkBk
If WkBkIsOpen Then
Set MasterWB = Workbooks("zmaster.xlsx")
Set MasterSht = MasterWB.Sheets("Blad1")
Else
Set MasterWB = Workbooks.Open(FolderPath & "zmaster.xlsx")
Set MasterSht = MasterWB.Sheets("Blad1")
End If
ProjectNumber = MasterSht.Cells(1, 1).Value
Do While Len(TempFile) > 0
'Checking that the file is not the master and that it is a xlsx
If Not TempFile = "zmaster.xlsx" And InStr(1, TempFile, "xlsx", vbTextCompare) Then
Set CopyRange = Nothing
'Note this is the last used Row, next empty row will be this plus 1
With MasterSht
MasterWBShtLstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set CurrentWB = Workbooks.Open(FolderPath & TempFile)
Set CurrentWBSht = CurrentWB.Sheets("Sheet1")
With CurrentWBSht
CurrentShtLstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For CurrentShtRowRef = 1 To CurrentShtLstRw
If CurrentWBSht.Cells(CurrentShtRowRef, "A").Value = ProjectNumber Then
'This is set to copy from Column A to Column L as per the question
If CopyRange Is Nothing Then
'If there is nothing in Copy range then union wont work
'so first row of the work sheet needs to set the initial copyrange
Set CopyRange = CurrentWBSht.Range("A" & CurrentShtRowRef & _
":L" & CurrentShtRowRef)
Else
'Union is quicker to be able to copy from the sheet once
Set CopyRange = Union(CopyRange, _
CurrentWBSht.Range("A" & CurrentShtRowRef & _
":L" & CurrentShtRowRef))
End If ' ending If CopyRange Is Nothing ....
End If ' ending If CurrentWBSht.Cells....
Next CurrentShtRowRef
CopyRange.Select
'add 1 to the master file last row to be the next open row
CopyRange.Copy MasterSht.Cells(MasterWBShtLstRw + 1, 1)
CurrentWB.Close savechanges:=False
End If 'ending If Not TempFile = "zmaster.xlsx" And ....
TempFile = Dir
Loop
End Sub
I have an excel sheet that in each cell in column A , the path of a source folder :
column A
P:\Desktop\Source\Test1-folder\file1.txt
P:\Desktop\Source\Test1-folder\file2.txt
and i want to take just the file name (file1.txt) for each file , how can i do it ? Can you help me please ?
For Each oFolder In oSourceFolder.SubFolders
lastcol = Cells(1, Cells.Columns.Count).End(xlToLeft).Column
For Each oFile In oFolder.Files
If Dir(destinationFolder, 16) = "" Then MkDir (destinationFolder)
For k = 1 To dercol
numrows = worksh.Cells(Rows.Count, icol).End(xlUp).Row
For w = 2 To numrows
filepath = worksh.Cells(w, icol).Value
But this one loops through the files, not the cells. How can I loop through the cells?
Try this:
' Get the sheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)
' How you will slash it
Dim strSlash As String
strSlash = "\"
' Set the range for your tool
Dim rngFiles As Range
Dim rngCell As Range
Dim lngMaxRow As Long
lngMaxRow = Range("A" & Rows.Count).End(xlUp).Row
Set rngFiles = Range("A1:A" & lngMaxRow)
' Grab it from the rear
For Each rngCell In rngFiles.Cells
Debug.Print Right(rngCell.Value, Len(rngCell.Value) - InStrRev(rngCell.Value, strSlash))
Next
If all you want is the file name, you can do this with a simple worksheet formula:
=TRIM(RIGHT(SUBSTITUTE(A1,"\",REPT(" ",99)),99))
I have raw data from ANSYS mechanical exported as .xml with the following format (2 rows, x number of columns):
Steps Time [s] [A] C1 (Total) [N]
1 1 1, 4,4163e+005
I have a lot of files and I'm trying to combine these into one table in Excel using VBA. The script works fine with one exception, it does not interpret the scientific format correctly. My result is as follows:
Steps 1
Time [s] 1
[A] C1 (Total) [N] 4,42E+09
Code looks as follows:
Private Sub CommandButton1_Click()
Dim directory As String, fileName As String, sheet As Worksheet, total As Integer
Dim wb1 As Excel.Workbook
Dim wb2 As Excel.Workbook
Set wb1 = ThisWorkbook
wb1.Sheets("Sheet1").Cells.ClearContents
'define table headers on row 1
wb1.Sheets("Sheet1").Range("A1:A1").Value = "Load Case"
wb1.Sheets("Sheet1").Range("B1:B1").Value = "Load Case"
wb1.Sheets("Sheet1").Range("C1:C1").Value = "Load Case"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'directory of source files
directory = "C:\Users\xxxxxxx\Ansysxls\"
fileName = Dir(directory & "*.xl??")
'Define the last used row in the target sheet
LastRow = wb1.Sheets("Sheet1").Cells(wb1.Sheets("Sheet1").Rows.Count, "B").End(xlUp).Row + 1
Do While fileName = "Asymmetric.xls"
'define which workbook to open
Set wb2 = Workbooks.Open(directory & fileName)
'loop through sheets in source file
For Each sheet In Workbooks(fileName).Worksheets
'Select range in source file
wb2.Sheets(sheet.Name).Range("A1").CurrentRegion.Select
'Replace commas with dot
Selection.Replace What:=",", Replacement:=".", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Selection.Copy
'Paste Special to target file <-----Smth wrong in my paste special???
wb1.Sheets("Sheet1").Range("B" & LastRow).PasteSpecial _
Paste:=xlPasteValuesAndNumberFormats, SkipBlanks:=True, Transpose:=True
wb2.Sheets(sheet.Name).Activate
Next sheet
'define first row and last row of last import and add from what file the came
FirstRow = LastRow
LastRow = wb1.Sheets("Sheet1").Cells(wb1.Sheets("Sheet1").Rows.Count, "B").End(xlUp).Row + 1
'remove file ending ".xls" from column
wb1.Sheets("Sheet1").Range("A" & FirstRow & ":" & "A" & LastRow).Value = Left(fileName, Len(fileName) - 4)
Workbooks(fileName).Close
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Create Table
wb1.Sheets("Sheet1").ListObjects.Add(xlSrcRange, Sheets("Sheet1").Range("A1").CurrentRegion, , xlYes, Header = xlYes).Name = "myTable1"
End Sub
Can anybody help me understand why it changes with from e+5 to e+9?
Excel will 'interpret' the Total [N]) value (which has the comma in it) depending on the numbering system of your Excel application.
I believe if you paste a value of 4,4163e+005 into your worksheet, you will see a value of 4416300000, assuming your thousands are comma separated. In your case, however, you seem to want to convert the comma to a decimal point so that the true value is 441630. This can only be done if the value is a string, but yours probably isn't, it's most likely a number. I'm afraid I rather suspect your search and replace line makes no changes at all.
Although I can't see the values themselves, my bet would be that you need to divide each value by 10000 and then set the number format of your cells to "0.0000E+00".
I've put some code below that will loop through the values and make that change for you. You'll see that I've assumed each sheet only contains the 2 x 4 cell size, so adjust this if you need to.
Other comments about your code:
I think you need to put your last row update within the sheet loop. At a quick glance it looks as though you might be overwriting previous sheet data (ie the only data being written to your target is the source's last sheet data).
I'm not sure what you're intentions are with the Dir() function and then checking for a unique filename. It looks to me as if that will only loop once on a file called "Asymmetric.xls". If this is what you want then just define that workbook as an object. If you want to read all the workbooks in the directory then you need to run the Dir() loop until filename = "". That's what I've assumed in my code.
Private Sub CommandButton1_Click()
Dim directory As String
Dim fileName As String
Dim source As Workbook
Dim sht As Worksheet
Dim targetRng As Range
Dim rawValues As Variant
Dim revisedValues() As Variant
Dim rDimension As Long
Dim cDimension As Integer
Dim r As Long
Dim c As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'define table headers on row 1
With ThisWorkbook.Sheets("Sheet1")
.Cells.ClearContents
.Cells(1, 1).Resize(, 3).Value = _
Array("Filename", "Item", "Value")
Set targetRng = .Cells(2, 2) 'ie "B2"
End With
'Directory of source files
directory = "C:\Users\xxxxxxx\Ansysxls\"
fileName = Dir(directory & "*.xl??")
Do Until fileName = ""
'define which workbook to open
Set source = Workbooks.Open(directory & fileName)
'loop through sheets in source file
For Each sht In source.Worksheets
'Select range in source file
If Not IsEmpty(sht.Range("A1")) Then
rawValues = sht.Range("A1").CurrentRegion.Value2
' Manipulate the acquired data
rDimension = UBound(rawValues, 1)
cDimension = UBound(rawValues, 2)
' Transpose the dimensions and manipulate the totalN value
ReDim revisedValues(1 To cDimension, 1 To rDimension)
For r = 1 To rDimension
For c = 1 To cDimension
If r = 2 And c = 4 Then ' it's totalN
' Convert the data to a LongLong and divide by 10000
revisedValues(c, r) = CLngLng(rawValues(r, c)) / 10000
Else
revisedValues(c, r) = rawValues(r, c)
End If
Next
Next
'Populate the target sheet with revised values
Set targetRng = targetRng.Resize(cDimension, rDimension)
targetRng.Value2 = revisedValues
' Define the scientific format
targetRng.Cells(4, 2).NumberFormat = "0.0000E+00"
' Add the filename to column "A"
targetRng.Offset(, -1).Resize(, 1).Value2 = _
Left(fileName, (InStrRev(fileName, ".", -1, vbTextCompare) - 1))
' Move the targetRng to the bottom of this range
Set targetRng = targetRng.Offset(targetRng.Rows.Count)
End If
Next
source.Close
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I am trying to reduce the file size of an Excel workbook I am using. I already know about unused rows being an issue and unnecessary images etc. The mystery is why there is a secret part of excel that only seems to grow?
I can discover the total size of my entire document with
Sub workbook_objectsize()
With CreateObject("Scripting.FileSystemObject")
Set wb = ActiveWorkbook
WBObjectSize = .GetFile(wb.fullname).Size
MsgBox (Format(WBObjectSize, "#,##0") & " Bytes")
End With
End Sub
and I can discover the size by sheet and the WB Object using
Sub GetSheetSizes()
' ZVI:2012-05-18 Excel VBA File Size by Worksheet in File
' CAR:2014-10-07 Enhanced to take hidden and very hidden sheets into account
Dim a() As Variant
Dim Bytes As Double
Dim i As Long
Dim fileNameTmp As String
Dim wb As Workbook
Dim visState As Integer
Set wb = ActiveWorkbook
ReDim a(0 To wb.Sheets.Count, 1 To 2)
' Turn off screen updating
Application.ScreenUpdating = False
On Error GoTo exit_
' Put names into a(,1) and sizes into a(,2)
With CreateObject("Scripting.FileSystemObject")
' Build the temporary file name
Err.Clear
fileNameTmp = .GetSpecialFolder(2) & "\" & wb.Name & ".TMP"
' Put workbook's name and size into a(0,)
a(0, 1) = wb.Name
a(0, 2) = .GetFile(wb.fullname).Size
' Put each sheet name and its size into a(i,)
For i = 1 To wb.Sheets.Count
visState = wb.Sheets(i).Visible
wb.Sheets(i).Visible = -1 ' Show sheet long enough to copy it
DoEvents
wb.Sheets(i).Copy
ActiveWorkbook.SaveCopyAs fileNameTmp
wb.Sheets(i).Visible = visState
a(i, 1) = wb.Sheets(i).Name
a(i, 2) = .GetFile(fileNameTmp).Size
Bytes = Bytes + a(i, 2)
ActiveWorkbook.Close False
Next
Kill fileNameTmp
End With
' Show workbook's name & size
Debug.Print a(0, 1), Format(a(0, 2), "#,##0") & " Bytes"
' Show workbook object's size
Debug.Print "Wb Object", Format(a(0, 2) - Bytes, "#,##0") & " Bytes"
' Show each sheet name and its size
For i = 1 To UBound(a)
Debug.Print a(i, 1), Format(a(i, 2), "#,##0") & " Bytes"
Next
exit_:
' Restore screen updating
Application.ScreenUpdating = True
' Show the reason of error if happened
If Err Then MsgBox Err.Description, vbCritical, "Error"
End Sub
Here is the exercise. I have MYWORKBOOK
step 1. check total file size and file size by sheet + wb object
MYWORKBOOK Ver0.34 test.xlsm 932,450 Bytes Total
Wb Object 201,679 Bytes
Home 312,904 Bytes
NISI_DETAIL 40,815 Bytes
DATABASE 49,186 Bytes
Settings 13,690 Bytes
NISI_LIST 27,484 Bytes
PleaseWait 21,232 Bytes
success 22,077 Bytes
Brands 34,721 Bytes
USER_LIST 26,819 Bytes
QUERY_LIST 37,880 Bytes
CAT_MAN_TOOLS 88,406 Bytes
Sheet1 9,997 Bytes
PROMO_LIST 45,560 Bytes
step 2. DELETE ALL SHEETS leaving only a new blank sheet1 and check again
MYWORKBOOK Ver0.34 test .xlsm 370,052 Bytes
Wb Object 361,589 Bytes
Sheet1 8,463 Bytes
Yes file size was reduced but thats because I deleted every sheet. However, this mysterious Wb Object actually got larger. What the hell??? nothing but a single blank sheet and a 370Kb file?????
BTW running this same test on a new workbook yeilds a Wb Object size of 0 Bytes.
TL;DR: What on earth is the Wb Object in the example above? Why does it keep growing? How can I reduce it back down to 0 Bytes?
For file reduction I use code but in your case I don't see that it will help based on what you have posted. I would be very keen to see the contents of the zip file per GSergs suggestion.
Here is my file reduction code if you want to try it but like I said, I don't see that it will get it as small as you are hoping but it's worth a try:
Sub LipoSuction2()
'Written by Daniel Donoghue 18/8/2009
'The purpose of this code is to offer an alternative to the original Liposuction code written by JBeaucaire for the MrExcel forums www.mrexcel.com
Dim ws As Worksheet
Dim CurrentSheet As String
Dim OldSheet As String
Dim Col As Long
Dim r As Long
Dim BottomrRow As Long
Dim EndCol As Long
'Begin addition 6/4/2010 for request: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
Dim Pic As Object
'End Addition 6/4/2010 for request: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
For Each ws In Worksheets
ws.Activate
'Put the sheets in a variable to make it easy to go back and forth
CurrentSheet = ws.Name
'Rename the sheet to its name with TRMFAT at the end
OldSheet = CurrentSheet & "TRMFAT"
ws.Name = OldSheet
'Add a new sheet and call it the original sheets name
Sheets.Add
ActiveSheet.Name = CurrentSheet
Sheets(OldSheet).Activate
'Find the bottom cell of data on each column and find the further row
For Col = 1 To Columns.Count 'Find the REAL bottom row
If Cells(Rows.Count, Col).End(xlUp).Row > BottomRow Then
BottomRow = Cells(Rows.Count, Col).End(xlUp).Row
End If
Next
'Find the end cell of data on each row that has data and find the furthest one
For r = 1 To BottomRow 'Find the REAL most right column
If Cells(r, Columns.Count).End(xlToLeft).Column > EndCol Then
EndCol = Cells(r, Columns.Count).End(xlToLeft).Column
End If
Next
'Copy the REAL set of data
Range(Cells(1, 1), Cells(BottomRow, EndCol)).Copy
Sheets(CurrentSheet).Activate
'Paste everything
Range("A1").PasteSpecial xlPasteAll
'Paste Column Widths
Range("A1").PasteSpecial xlPasteColumnWidths
'Begin addition 6/4/2010 for request: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
Sheets(OldSheet).Activate
For Each Pic In ActiveSheet.Pictures
Pic.Copy
Sheets(CurrentSheet).Paste
Sheets(CurrentSheet).Pictures(Pic.Index).Top = Pic.Top
Sheets(CurrentSheet).Pictures(Pic.Index).Left = Pic.Left
Next
Sheets(CurrentSheet).Activate
'End Addition 6/4/2010 for request: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
'Reset the variable for the next sheet
BottomRow = 0
EndCol = 0
Next
'Excel will automatically replace the sheet references for you on your formulas, the below part puts them back
'This is done with a simple reaplce, replacing TRMFAT with nothing
For Each ws In Worksheets
ws.Activate
Cells.Replace "TRMFAT", ""
Next
'Poll through the sheets and delete the original bloated sheets
For Each ws In Worksheets
If Not Len(Replace(ws.Name, "TRMFAT", "")) = Len(ws.Name) Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next
End Sub
I found some excel workbooks that had imported too much data resulting in worksheets with over 16k columns & 65k rows - Couldn't operate - found a way to delete columns & rows - trick was to start at the end, work backwards & save along the way. reduced filesize from 3mb to 125k.. Code below - read, test, and use at your own risks...
Function delsht()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.CutCopyMode = False
Sheet3.AutoFilterMode = False
DoEvents
Debug.Print Sheet3.UsedRange.Address
' c = psht.UsedRange.Columns(psht.UsedRange.Columns.Count).Column
' For i = c To 1500 Step -500
' psht.Range(Columns(i), Columns(i - 500)).Delete
' DoEvents
' ActiveWorkbook.Save
' Debug.Print i, Time()
' Next i
r = Sheet3.UsedRange.Rows(Sheet3.UsedRange.Rows.Count).Row
For i = r To 2000 Step -500
Sheet3.Range(Rows(i), Rows(i - 500)).Delete
DoEvents
ActiveWorkbook.Save
Debug.Print i, Time()
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Debug.Print "done."
End Function
Function bloatfinder()
Dim sht As Worksheet
For Each sht In Application.ActiveWorkbook.Sheets
Debug.Print sht.Name, sht.UsedRange.Address,
c = sht.UsedRange.Columns(sht.UsedRange.Columns.Count).Column
r = sht.UsedRange.Rows(sht.UsedRange.Rows.Count).Row
Debug.Print " Rows:", r, "Cols:", c
Next
Set sht = Nothing
End Function
I'm searching for a macro to take an excel file of several rows and split the sheet's rows up into sheets of any amount of rows we desire per-sheet, including the original rows, which should also be copied to each sheet.
In simple if i have a file with row
1
2
3
then that macro split the rows make a sheet with .csv file like these so we get a 3 file form above
file1 file2 file3
1 1 1
2 2
3
i hope you get the point
i searched for it but only able to find
Option Explicit
Sub SplitWorkbooksByNrows()
'Jerry Beaucaire, 2/28/2012
'Split all data sheets in a folder by a variable number or rows per sheet, optional titles
'assumes only one worksheet of data per workbook
Dim N As Long, rw As Long, LR As Long, Cnt As Long, Cols As String, Titles As Boolean
Dim srcPATH As String, destPATH As String, fNAME As String, wbDATA As Workbook, titleRNG As Range
srcPATH = "C:\Path\To\Source\Files\" 'remember the final \ in this string
destPATH = "C:\Path\To\Save\NewFiles\" 'remember the final \ in this string
'determine how many rows per sheet to create
N = Application.InputBox("How many rows per sheet?", "N-Rows", 50, Type:=1)
If N = 0 Then Exit Sub 'exit if user clicks CANCEL
'Examples of usable ranges: A:A A:Z C:E F:F
Cols = Application.InputBox("Enter the Range of columns to copy", "Columns", "A:Z", Type:=2)
If Cols = "False" Then Exit Sub 'exit if user clicks CANCEL
'prompt to repeat row1 titles on each created sheet
If MsgBox("Include the title row1 on each new sheet?", vbYesNo, _
"Titles?") = vbYes Then Titles = True
Application.ScreenUpdating = False 'speed up macro execution
Application.DisplayAlerts = False 'turn off system alert messages, use default answers
fNAME = Dir(srcPATH & "*.xlsx") 'get first filename from srcPATH
Do While Len(fNAME) > 0 'exit loop when no more files found
Set wbDATA = Workbooks.Open(srcPATH & fNAME) 'open found file
With ActiveSheet
LR = Intersect(.Range(Cols), .UsedRange).Rows.Count 'how many rows of data?
If Titles Then Set titleRNG = Intersect(.Range(Cols), .Rows(1)) 'set title range, opt.
For rw = 1 + ---Titles To LR Step N 'loop in groups of N rows
Cnt = Cnt + 1 'increment the sheet creation counter
Sheets.Add 'create the new sheet
If Titles Then titleRNG.Copy Range("A1") 'optionally add the titles
'copy N rows of data to new sheet
Intersect(.Range("A" & rw).Resize(N).EntireRow, .Range(Cols)).Copy Range("A1").Offset(Titles)
ActiveSheet.Columns.AutoFit 'cleanup
ActiveSheet.Move 'move created sheet to new workbook
'save with incremented filename in the destPATH
ActiveWorkbook.SaveAs destPATH & "Datafile_" & Format(Cnt, "00000") & ".xlsx", xlNormal
ActiveWorkbook.Close False 'close the created workbook
Next rw 'repeat with next set of rows
End With
wbDATA.Close False 'close source data workbook
fNAME = Dir 'get next filename from the srcPATH
Loop 'repeat for each found file
Application.ScreenUpdating = True 'return to normal speed
MsgBox "A total of " & Cnt & " data files were created." 'report
End Sub
Reference https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/parse-functions/rows
What this macro is doing
if we have these rows
1
2
3
Macro doing this
file1 file2 file3
1 2 3
The code which is provided do exactly what i wanted but only if the macro can add the rows to. Like this.
file1 file2 file3
1 1 1
2 2
3
This may help get you started. You'll need to put your own range references and filepaths etc.
Sub SplitAndSave()
Dim rows As Long, rw As Long, myFolder As String, ws As Worksheet
rows = Worksheets("Sheet1").Range("A1:A10").rows.Count
myFolder = "C:\Users\Desktop\MyFolder\"
Set ws = Worksheets("Sheet2")
For rw = 1 To rows
ws.Cells.ClearContents
Range("A1:A" & rw).Copy Destination:=ws.Range("A1")
ws.SaveAs myFolder & "file" & rw & ".csv", xlCSV
Next rw
End Sub
This will split your data in Range(A1:A10) in to ten separate .csv files and place them in a folder called MyFolder on the desktop.