Double loop (loop inside a loop) vba excel - vba

I am relatively new to VBA, and am in need of some help to fully understand some issues.
I have a file with many sheets, and am in need to make a copy of the file for every team. Each file must not have the information of other teams.
I have managed to assemble this code that seems to work for one sheet, but not for every sheet that I need.
The first four sheets are supposed to remain unchanged (no filtering in these ones) and the sheet in yellow is a different arrangement from the others (I need to look at this later) but the remaining sheets have exactly the same construction, so the column to do "the math" is the same. (file in attachment with example)
Sub DeleteRowBasedOnCriteria()
'lobs names
Dim lob(14) As String
lob(0) = "AV"
lob(1) = "CA"
lob(2) = "G_13"
lob(3) = "HSTP"
lob(4) = "JLS"
lob(5) = "JR"
lob(6) = "LPV"
lob(7) = "MAO"
lob(8) = "NML"
lob(9) = "PRJ"
lob(10) = "RB"
lob(11) = "RG"
lob(12) = "SPN"
lob(13) = "VE"
'counter
Dim i As Integer
'numbers of rows
Dim rowtotest As Long
' to create a copy of the template to be filled'
Dim sFile As String 'Source file - Template'
Dim sDFile As String 'Destination file - Template'
Dim sSFolder As String 'Source folder - Template'
Dim sDFolder As String 'Destination Folder'
sSFolder = "C:\Users\Pacosta\Desktop\ParaIndividuals\team.xlsx"
MsgBox (sSFolder)
'Destination Path Window selector
Dim destinationWindow As FileDialog
Set destinationWindow = Application.FileDialog(msoFileDialogFolderPicker)
destinationWindow.Title = "Select Destination Folder"
'only select one folder
destinationWindow.AllowMultiSelect = False
If destinationWindow.Show Then
sDFolder = destinationWindow.SelectedItems(1) + "\"
End If
'copy cell content to excel file based on template with bookmarks'
Dim objExcel As Object
Dim ws As Worksheet
For i = 0 To 14
'create a file with same name as lob
sDFile = lob(i) + ".xlsx"
'Create object excel document'
Set FSO = CreateObject("Scripting.FileSystemObject")
'Copy the template do destination'
FSO.CopyFile (sSFolder + sFile), sDFolder + sDFile, True
Next i
Dim file As String
For i = 0 To 11
file = sDFolder + lob(i) + ".xlsx"
Call GetIndices(lob(i), file)
Next i
End Sub
'delete rows diferents from lobs namefile
Sub DeleteRows(lob As String, file As String)
'disable automatic calculation
Application.Calculation = xlCalculationManual
'count number of rows
Dim rowtotest As Long
'variable to work with all files
Dim ficheiro As Workbook
Set ficheiro = Workbooks.Open(file)
With ficheiro.Sheets(1)
'delete rows of the other lob's
For rowtotest = .Cells(Rows.Count, 7).End(xlUp).Row + 1 To 5 Step -1
If StrComp(.Cells(rowtotest, 7).Value, lob) <> 0 Then
.Rows(rowtotest).Delete
End If
Next rowtotest
End With
' Force a calculation
Application.Calculate
' Then remember to run automatic calculations back on
Application.Calculation = xlCalculationAutomatic
'save file
ficheiro.Save
'close file
ficheiro.Close
End Sub
Sub GetIndices(lob As String, file As String)
'count number of rows
Dim rowtotest As Long
'primeiro indice
Dim indice1 As Integer
'segundo indice
Dim indice2 As Integer
'variable to work with all files
Dim ficheiro As Workbook
Set ficheiro = Workbooks.Open(file)
With ficheiro.Sheets(1)
'delete rows of the other lob's
For rowtotest = .Cells(Rows.Count, 8).End(xlUp).Row + 1 To 5 Step -1
If StrComp(.Cells(rowtotest, 8).Value, lob) = 0 Then
indice2 = rowtotest
rowtotest = 0
End If
Next rowtotest
'delete rows of the other lob's
For rowtotest = 4 To .Cells(Rows.Count, 8).End(xlUp).Row + 1 Step 1
If StrComp(.Cells(rowtotest, 8).Value, lob) = 0 Then
indice1 = rowtotest
rowtotest = 1000
End If
Next rowtotest
Dim texto As String
texto = indice2 & ":" & .Cells(Rows.Count, 8).End(xlUp).Row + 1
.Rows(texto).Delete
texto = 5 & ":" & indice1
.Rows(texto).Delete
ficheiro.Save
ficheiro.Close
End With
End Sub
Can someone help me with this problem?
Thanks in advance.

Related

VBA for copying multiple columns from different workbooks to be in columns next to each other

I am trying to pull data from a folder containing 300 Workbooks, each named 001, 002 etc.
I am only interested in pulling the data from column G of each file and copying it into a separate folder (each file does not have the same amount if data in row G)
I have been able to copy the data across, but I can't seem to get it to move past column 2 and instead writes over the previous column.
The output needed is:
data from column G workbook"001" pasted into "new sheet" column A
data from column G workbook"002" pasted into "new sheet" column B
and so on
Each file in the folder of 300 only has 1 worksheet each, each labelled: 001,002,...,300
This is the code I already had which results in 2 columns of data where 1 gets replaced by each new sheet instead.
Any help to solve this issue would be greatly appreciated.
Sub Copy()
Dim MyFile As String
Dim Filepath As String
Dim q As Long
Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer
Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1
Filepath = "C:..."
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Text to column.xlsm" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
LastRow = Range("G1").CurrentRegion.Rows.Count
Range("G1", Range("G" & LastRow)).Copy ThisWorkbook.Sheets("Sheet1").Range(CurS.Cells(ThisRow, ThisCol + 1), CurS.Cells(ThisRow, ThisCol + CurS.Cells(ThisRow, InfCol).Value))
ActiveWorkbook.Save
ActiveWorkbook.Close
MyFile = Dir
Loop
End Sub
To properly copy in a new column each time, you need a variable that increments during each loop to offset by one each time. When you use ThisCol + 1 you're always getting the same value because ThisCol is not updated.
Something like this:
Sub Copy()
Dim MyFile As String
Dim Filepath As String
Dim q As Long
Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer
Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1
Filepath = ReplacewithyouFilePath
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Text to column.xlsm" Then
Exit Sub
End If
'Let's keep a reference to the workbook
Dim wb As Workbook
Set wb = Workbooks.Open(Filepath & MyFile)
'Let's keep a reference to the first sheet where the data is
Dim ws As Worksheet
Set ws = wb.Sheets(1)
Dim LastRow As Long
LastRow = ws.Range("G1").CurrentRegion.Rows.Count
'We create a variable to increment at each column
Dim Counter As Long
'Let's make the copy operation using the Counter
ws.Range("G1", ws.Range("G" & LastRow)).Copy CurS.Range(CurS.Cells(ThisRow, ThisCol + Counter), CurS.Cells(ThisRow + LastRow - 1, ThisCol + Counter))
'We increment the counter for the next file
Counter = Counter + 1
'We use wb to make sure we are referring to the right workbook
wb.Save
wb.Close
MyFile = Dir
'We free the variables for good measure
Set wb = Nothing
Set ws = Nothing
Loop
End Sub
Import Columns
Sub ImportColumns()
Const FOLDER_PATH As String = "C:\Test"
Const FILE_EXTENSION_PATTERN As String = "*.xls*"
Const SOURCE_WORKSHEET_ID As Variant = 1
Const SOURCE_COLUMN As String = "G"
Const SOURCE_FIRST_ROW As Long = 1
Const DESTINATION_WORKSHEET_NAME As String = "Sheet1"
Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
Const DESTINATION_COLUMN_OFFSET As Long = 1
Dim pSep As String: pSep = Application.PathSeparator
Dim FolderPath As String: FolderPath = FOLDER_PATH
If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
Dim DirPattern As String: DirPattern = FolderPath & FILE_EXTENSION_PATTERN
Dim SourceFileName As String: SourceFileName = Dir(DirPattern)
If Len(SourceFileName) = 0 Then
MsgBox "No files found.", vbExclamation
Exit Sub
End If
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets(DESTINATION_WORKSHEET_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
Application.ScreenUpdating = False
Dim swb As Workbook
Dim sws As Worksheet
Dim srg As Range
Dim sfCell As Range
Dim slCell As Range
Do While Len(SourceFileName) > 0
If StrComp(SourceFileName, "Text to column.xlsm", vbTextCompare) _
<> 0 Then ' Why 'Exit Sub'? Is this the destination file?
Set swb = Workbooks.Open(FolderPath & SourceFileName, True, True)
Set sws = swb.Worksheets(SOURCE_WORKSHEET_ID)
Set sfCell = sws.Cells(SOURCE_FIRST_ROW, SOURCE_COLUMN)
Set slCell = sws.Cells(sws.Rows.Count, SOURCE_COLUMN).End(xlUp)
Set srg = sws.Range(sfCell, slCell)
srg.Copy dfCell
' Or, if you only need values without formulas and formats,
' instead, use the more efficient:
'dfCell.Resize(srg.Rows.Count).Value = srg.Value
Set dfCell = dfCell.Offset(, DESTINATION_COLUMN_OFFSET) ' next col.
swb.Close SaveChanges:=False ' we are just reading, no need to save!
'Else ' it's "Text to column.xlsm"; do nothing
End If
SourceFileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Columns imported.", vbInformation
End Sub

VBA- Import Multiple CSV to a Sheet, Remove Certain Rows/Columns

I am completely new to VBA, but I have CSV files(same format for all of them), and I want to import them to a single sheet on Excel. I was able to read the CSV file according to this code:
Sub R_AnalysisMerger()
Dim WSA As Worksheet
Dim bookList As Workbook
Dim SelectedFiles() As Variant
Dim NFile As Long
Dim FileName As String
Dim ws As Worksheet, vDB As Variant, rngT As Range
Application.ScreenUpdating = False
'Selects the CSV files as SELECTED FILES
Set ws = ThisWorkbook.Sheets(1)
ws.UsedRange.Clear 'Clears current worksheet
SelectedFiles = Application.GetOpenFilename(filefilter:="Excel Files (*.csv*), *.csv*", MultiSelect:=True) 'Selects csv files
For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
FileName = SelectedFiles(NFile)
Set bookList = Workbooks.Open(FileName, Format:=2)
Set WSA = bookList.Sheets(1)
With WSA
vDB = .UsedRange
Set rngT = ws.Range("a" & Rows.count).End(xlUp)(2)
If rngT.Row = 2 Then Set rngT = ws.Range("A1")
rngT.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
bookList.Close (0)
End With
Next
Application.ScreenUpdating = True
ws.Range("A1").Select
But I have additional requirements:
Skip the first column.
Skip the first four rows.
Remove a certain String from each word in the fifth row.
Im used to java, and usually I would read each line with a "for" loop and set "if" statements to skip the first row and four columns and remove the string from each string if it was present.
I don't know how to do this with this code. From what I understand it just copies the whole CSV file into the sheet?
This solution is based on reading CSV as textstream. I have tried to include feature that makes possible most all things like selecting columns, Rows and so on.
Sub ImportCSV()
Dim fso As New IWshRuntimeLibrary.FileSystemObject
Dim txtStream As IWshRuntimeLibrary.TextStream
Dim files As IWshRuntimeLibrary.files
Dim file As IWshRuntimeLibrary.file
Dim txtLine As String
Dim lineCount As Integer
Dim lastRow As Integer
Dim lineCol As Variant
Dim rng As Range
Application.ScreenUpdating = False
ThisWorkbook.Sheets(1).usedRange.Delete
Set rng = ThisWorkbook.Sheets(1).usedRange
lastRow = 1
Set files = fso.GetFolder("path\folder").files
For Each file In files
If file.Name Like "*.csv" Then
Set txtStream = file.OpenAsTextStream(ForReading, TristateUseDefault)
txtStream.SkipLine ' skip first line, since it containes headers
lineCount = 1
Do
txtLine = txtStream.ReadLine
If lineCount = 5 Then
txtLine = Replace(txtLine, "stringToReplace", "StringToReplcaeWith") ' replace certain string from words in 5'th row
End If
lineCount = lineCount + 1
lineCol = sliceStr(Split(txtLine, ";"), startIdx:=4) ' slice the array so to skip four first columns
For iCol = 0 To UBound(lineCol) ' write columns to last row
rng(lastRow, iCol + 1).Value = lineCol(iCol)
Next iCol
lastRow = lastRow + 1
'Debug.Print Join(lineCol, ";") ' debug
Loop Until txtStream.AtEndOfStream
End If
Next file
Application.ScreenUpdating = True
End Sub
This is the slicer function
Function sliceStr(arr As Variant, startIdx As Integer, Optional stopIdx As Integer = 0) As String()
If stopIdx = 0 Then
stopIdx = UBound(arr)
End If
Dim tempArrStr() As String
ReDim tempArrStr(stopIdx - startIdx)
Dim counter As Integer
counter = 0
For i = startIdx To stopIdx
tempArrStr(counter) = arr(i)
counter = counter + 1
Next
sliceStr = tempArrStr
End Function
I just did a simple test and the code below seems to work. Give it a go, and feedback.
Sub Demo()
Dim fso As Object 'FileSystemObject
Dim fldStart As Object 'Folder
Dim fld As Object 'Folder
Dim fl As Object 'File
Dim Mask As String
Application.ScreenUpdating = False
Dim newWS As Worksheet
Set newWS = Sheets.Add(before:=Sheets(1))
Set fso = CreateObject("scripting.FileSystemObject") ' late binding
'Set fso = New FileSystemObject 'or use early binding (also replace Object types)
Set fldStart = fso.GetFolder("C:\Users\ryans\OneDrive\Desktop\output\") ' <-- use your FileDialog code here
Mask = "*.csv"
'Debug.Print fldStart.Path & ""
ListFiles fldStart, Mask
For Each fld In fldStart.SubFolders
ListFiles fld, Mask
ListFolders fld, Mask
Next
Dim myWB As Workbook, WB As Workbook
Set myWB = ThisWorkbook
Dim L As Long, t As Long, i As Long
L = myWB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
t = 1
For i = 1 To L
Workbooks.OpenText Filename:=myWB.Sheets(1).Cells(i, 1).Value, DataType:=xlDelimited, Tab:=True
Set WB = ActiveWorkbook
lrow = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
WB.Sheets(1).Range("B4:E" & lrow).Copy newWS.Cells(t, 2)
t = myWB.Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row + 1
WB.Close False
Next
myWB.Sheets(1).Columns(1).Delete
Application.ScreenUpdating = True
End Sub
Sub ListFolders(fldStart As Object, Mask As String)
Dim fld As Object 'Folder
For Each fld In fldStart.SubFolders
'Debug.Print fld.Path & ""
ListFiles fld, Mask
ListFolders fld, Mask
Next
End Sub
Sub ListFiles(fld As Object, Mask As String)
Dim t As Long
Dim fl As Object 'File
For Each fl In fld.Files
If fl.Name Like Mask Then
t = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1
'Debug.Print fld.Path & "" & fl.Name
If Sheets(1).Cells(1, 1) = "" Then
Sheets(1).Cells(1, 1) = fld.Path & "\" & fl.Name
Else
Sheets(1).Cells(t, 1) = fld.Path & "\" & fl.Name
End If
End If
Next
End Sub

Vba code runtime error cant open the file (currupt )

i am trying to copy a file to a new location several times(one for eatch lob name) and after i need to delete from eatch file all the rows that doesnt meet a criteria. DFor some reason i have two errors, one stating that the file cant be opened (error 1004 cant open file or file currupt) and if i change the code to save the files as xlsm it doesnt give any error, but the code doesnt do anithing, any ideas?
here is the code that i am using
Thanks in advance for your help
Sub DeleteRowBasedOnCriteria()
Application.ScreenUpdating = False
'lobs names
Dim lob(15) As String
lob(0) = "test1"
lob(1) = "test2"
lob(2) = "test3"
lob(3) = "test4"
lob(4) = "test5"
lob(5) = "test6"
lob(6) = "test7"
lob(7) = "test8"
lob(8) = "test9"
lob(9) = "test10"
lob(10) = "test11"
lob(11) = "test12"
lob(12) = "test13"
lob(13) = "test14"
lob(14) = "test15"
'counter
Dim i As Integer
'numbers of rows
Dim rowtotest As Long
' to create a copy of the template to be filled'
Dim sDFile As String 'Destination file - Template'
Dim sSFolder As String 'Source file - Template'
Dim sDFolder As String 'Destination Folder'
'Source File Selector
Dim sourceWindow As FileDialog
Set sourceWindow = Application.FileDialog(msoFileDialogFilePicker)
sourceWindow.Title = "Select Source File"
'only select one file
sourceWindow.AllowMultiSelect = False
If sourceWindow.Show Then
sSFolder = sourceWindow.SelectedItems(1)
End If
'Destination Path Window selector
Dim destinationWindow As FileDialog
Set destinationWindow = Application.FileDialog(msoFileDialogFolderPicker)
destinationWindow.Title = "Select Destination Folder"
'only select one folder
destinationWindow.AllowMultiSelect = False
If destinationWindow.Show Then
sDFolder = destinationWindow.SelectedItems(1) + "\"
End If
'copy cell content to excel file based on template with bookmarks'
Dim objExcel As Object
Dim ws As Worksheet
For i = 0 To 15
'create a file with same name as lob
sDFile = lob(i) + ".xlsx"
'Create object excel document'
Set FSO = CreateObject("Scripting.FileSystemObject")
'Copy the template do destination'
FSO.CopyFile (sSFolder), sDFolder + sDFile, True
Next i
Dim file As String
For i = 0 To 15
file = sDFolder + lob(i) + ".xlsx"
Call GetIndices(lob(i), file)
Next i
MsgBox ("Individuals Criados com Sucesso!")
Application.ScreenUpdating = True
End Sub
'Finding the superior and inferior indice and deleting the intermidial intervals
Sub GetIndices(lob As String, file As String)
Application.ScreenUpdating = False
'count number of rows
Dim rowtotest As Long
'first indice
Dim indice1 As Integer
'second indice
Dim indice2 As Integer
'variable to work with all files
Dim ficheiro As Workbook
Set ficheiro = Workbooks.Open(file)
With ficheiro.Sheets(1)
'delete rows of the other lob's
For rowtotest = .Cells(Rows.Count, 241).End(xlUp).Row + 1 To 5 Step -1 '7 a coluna de pesquisa da lob
If StrComp(.Cells(rowtotest, 241).Value, lob) = 0 Then
indice2 = rowtotest
rowtotest = 0 'obrigar a sair do ciclo assim que tiver encontrado os registos
End If
Next rowtotest
'delete rows of the other lob's
For rowtotest = 3 To .Cells(Rows.Count, 241).End(xlUp).Row + 1 Step 1 '4 Ž a primeira linha de registos, o que est‡ acima s‹o headers
If StrComp(.Cells(rowtotest, 241).Value, lob) = 0 Then
indice1 = rowtotest
rowtotest = 50000 'obrigar a sair do ciclo assim que tiver encontrado os registos
End If
Next rowtotest
'delete rows based on indices and create a range
Dim texto As String
texto = indice2 + 1 & ":" & .Cells(Rows.Count, 241).End(xlUp).Row + 1 '7 Ž a coluna de pesquisa da lob
.Rows(texto).Delete
If indice1 > 6 Then
'delete rows based on indices and create a range
texto = 3 & ":" & indice1 - 1
.Rows(texto).Delete
End If
End With
Application.ScreenUpdating = True
End Sub

combine multiple text files in a single excel sheet

I have 27 txt files with the same format and columns, and I want to append all of these in a single excel sheet. I have checked some previous threads here, but I could only find the code below which helped me to import txt fiels into separate sheets. However, I also want to append these separate sheets into a sheet that I want to append all my data.
Sub Test()
'UpdatebyExtendoffice6/7/2016
Dim xWb As Workbook
Dim xToBook As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
Dim xFiles As New Collection
Dim I As Long
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder [Vendor_data_25DEC]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
If Right(xStrPath, 1) <> "\" Then xStrPath = xStrPath & "\"
xFile = Dir(xStrPath)
'xFile = Dir(xStrPath & "*.txt") 'this is the original version that you can amend according to file extension
If xFile = "" Then
MsgBox "No files found", vbInformation, "Vendor_data_25DEC"
Exit Sub
End If
Do While xFile <> ""
xFiles.Add xFile, xFile
xFile = Dir()
Loop
Set xToBook = ThisWorkbook
If xFiles.Count > 0 Then
For I = 1 To xFiles.Count
Set xWb = Workbooks.Open(xStrPath & xFiles.Item(I))
xWb.Worksheets(1).Copy after:=xToBook.Sheets(xToBook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xWb.Name
On Error GoTo 0
xWb.Close False
Next
End If
End Sub
I am not sure how to do this with VBA in order to combine the data in separate sheets into a single sheet quickly. I know the consolidate feature of excel but it also includes lots of manual steps, so I seek for a faster and automated solution. Any help is much appreciated.
Thanks a lot in advance.
Sub Combiner()
Dim strTextFilePath$, strFolder$
Dim wksTarget As Worksheet
Dim wksSource As Worksheet
Dim x As Long
Set wksTarget = Sheets.Add()
strFolder = "c:\Temp\test\"
strTextFilePath = Dir(strFolder)
While Len(strTextFilePath) > 0
'// "x" variable is just a counter.
'// It's purpose is to track whether the iteration is first or not.
'// If iteration is first (x=1), then we include header (zero offset down),
'// otherwise - we make an offset (1 row offset down).
x = x + 1
Set wksSource = Workbooks.Open(strFolder & strTextFilePath).Sheets(1)
With wksTarget
wksSource.Range("A1").CurrentRegion.Offset(IIf(x = 1, 0, 1)).Copy _
.Cells(.Rows.Count, 1).End(xlUp).Offset(1)
End With
wksSource.Parent.Close False
strTextFilePath = Dir()
Wend
MsgBox "Well done!", vbInformation
End Sub

split spreadsheet/excel file into multiple csv files with UTF-8 encoding

The below code successfully converts big excel files in to csv files with the specified number of rows.
How ever I want the output file to be UTF-8 encoded CSV files.
How to add UTF-8 code to below, I would like to combine the below splitting file code with UTF-8 conversion code
Sub test()
Dim wb As Workbook
Dim ThisSheet As Worksheet
Dim NumOfColumns As Integer
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?
Application.ScreenUpdating = False
'Initialize data
Set ThisSheet = ThisWorkbook.ActiveSheet
NumOfColumns = ThisSheet.UsedRange.Columns.Count
WorkbookCounter = 1
RowsInFile = 5 'as your example, just 10 rows per file
'Copy the data of the first row (header)
Set RangeOfHeader = ThisSheet.Range(ThisSheet.Cells(1, 1), ThisSheet.Cells(1, NumOfColumns))
For p = 2 To ThisSheet.UsedRange.Rows.Count Step RowsInFile - 1
Set wb = Workbooks.Add
'Paste the header row in new file
RangeOfHeader.Copy wb.Sheets(1).Range("A1")
'Paste the chunk of rows for this file
Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 2, NumOfColumns))
RangeToCopy.Copy wb.Sheets(1).Range("A2")
'Save the new workbook, and close it
wb.SaveAs ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & "_v" & WorkbookCounter & ".csv", FileFormat:=xlCSV
wb.Close True
'Increment file counter
WorkbookCounter = WorkbookCounter + 1
Next p
Application.ScreenUpdating = True
Set wb = Nothing
End Sub
You could use the ADODB library Stream object. The below code uses early binding so don't forget to tick the relevant MS ActiveX Data Object reference accordingly before running.
Sub saveAsUTF8()
Dim myStream As ADODB.Stream
Dim ws As Worksheet
Dim curRow As String
Dim curRowRng As Range
Dim curCell As Range
Set myStream = New ADODB.Stream
Set ws = ThisWorkbook.ActiveSheet
With myStream
.Type = adTypeText
.Charset = "UTF-8"
.Open
For Each curRowRng In ws.UsedRange.Rows
curRow = ""
For Each curCell In curRowRng.Cells
curRow = curRow & "," & curCell.Value
Next curCell
curRow = Right(curRow, Len(curRow) - 1)
.WriteText curRow, adWriteLine
Next curRowRng
'CHANGE TO YOU DESTINATION DIRECTORY
.SaveToFile "YOUR_PATH\utf8file.csv", adSaveCreateOverWrite
.Close
End With
End Sub