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
Related
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
I have a folder with 50 excel files I need to open, copy, paste, close and open the next one.
The macro is working until the loop, but it is not opening the next file. It stops
Any suggestion?
Sub open_and_close()
Dim MyFolder As String
Dim MyFile As Variant
Dim LC3 As Long
Dim WB1 As Workbook
Dim WB2 As Workbook
Set WB1 = ThisWorkbook
MyFolder = "C:\Users\x\y\z\Test script\"
MyFile = Dir(MyFolder & "*.xlsx")
Do While MyFile <> ""
Workbooks.Open (MyFolder & MyFile)
Set WB2 = ActiveWorkbook
ActiveWorkbook.Sheets("Test Script Scenario 1").Range("J3:J99").Copy
WB1.Sheets("Test Script Scenario 1").Activate
LC3 = Cells(3, Columns.Count).End(xlToLeft).Column
Cells(3, LC3 + 1).PasteSpecial Paste:=xlPasteValues
Cells(1, LC3 + 1) = Dir(WB2.Name)
WB2.Close savechanges:=False
MyFile = Dir()
Loop
End Sub
I always avoid DIR as it behaves strange if called several times.
I assume that's your problem - as you call Dir(wb2.name).
Try using FilesystemObject.
You have to add a reference to your project:
Furthermore it's not necessary to copy/paste >> see sub copyRangeValues
Plus: consider using a table (Insert > table) than it is much easier to add new columns.
Option Explicit
Private Const pathToFiles As String = "C:\Users\x\y\z\Test script\"
Private Const SourceSheetname As String = "Test Script Scenario 1"
Private Const SourceAddressToCopy As String = "J3:J99"
Private Const TargetSheetname As String = "Test Script Scenario 1"
Private Const TargetStartRow As Long = 3
Sub readDataFromFiles()
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim SourceFolder As Folder
Set SourceFolder = fso.GetFolder(pathToFiles)
Dim SourceFile As File, wbSource As Workbook
For Each SourceFile In SourceFolder.Files
If SourceFile.Name Like "*.xlsx" Then
Set wbSource = getWorkbook(pathToFiles & "\" & SourceFile.Name)
copyDataFromSource wbSource
wbSource.Close False
End If
Next
End Sub
Private Sub copyDataFromSource(wbSource As Workbook)
Dim rgSource As Range
Set rgSource = wbSource.Worksheets(SourceSheetname).Range(SourceAddressToCopy)
Dim rgTargetCell As Range
Set rgTargetCell = getTargetCell
copyRangeValues rgSource, rgTargetCell
'add filename to row 1
rgTargetCell.Offset(TargetStartRow - 2).Value = wbSource.Name
End Sub
Private Function getTargetCell() As Range
Dim wsTarget As Worksheet: Set wsTarget = ThisWorkbook.Worksheets(TargetSheetname)
'I copied your code - but it looks weird to me
'think of using a table and then your can work with the listobject to add a new column
Dim LC3 As Long
With wsTarget
LC3 = .Cells(3, .Columns.Count).End(xlToLeft).Column
End With
Set getTargetCell = wsTarget.Cells(TargetStartRow, LC3)
End Function
Public Sub copyRangeValues(rgSource As Range, rgTargetCell As Range)
'generic routine to copy one range to another
'rgTargetCell = top left corner of target range
Dim rgTarget As Range
'resize rgTarget according to dimensions of rgSource
With rgSource
Set rgTarget = rgTargetCell.Resize(.Rows.Count, .Columns.Count)
End With
'write values from rgSource to rgTarget - no copy/paste necessary!!!
'formats are not copied - only values
rgTarget.Value = rgSource.Value
End Sub
Private Function getWorkbook(FullFilename As String) As Workbook
Dim wb As Workbook
Set wb = Application.Workbooks.Open(FullFilename)
Set getWorkbook = wb
End Function
First collect the files in an array, then process the files.
Sub open_and_close()
Dim MyFolder As String
Dim MyFile As Variant, Files As Variant
Dim LC3 As Long, NumFiles As Long, Idx As Long
Dim WB1 As Workbook, WB2 As Workbook
Set WB1 = ThisWorkbook
MyFolder = "C:\Users\x\y\z\Test script\"
' First collect the files in an array
MyFile = Dir(MyFolder & "*.xlsx")
NumFiles = 0
Do While MyFile <> ""
NumFiles = NumFiles + 1
If NumFiles = 1 Then
ReDim Files(1 To 1)
Else
ReDim Preserve Files(1 To NumFiles)
End If
Files(NumFiles) = MyFile
MyFile = Dir()
Loop
' Then process the files
For Idx = 1 To NumFiles
MyFile = Files(Idx)
Set WB2 = Workbooks.Open(MyFolder & MyFile)
ActiveWorkbook.Sheets("Test Script Scenario 1").Range("J3:J99").Copy
WB1.Sheets("Test Script Scenario 1").Activate
LC3 = Cells(3, Columns.Count).End(xlToLeft).Column
Cells(3, LC3 + 1).PasteSpecial Paste:=xlPasteValues
Cells(1, LC3 + 1) = Dir(WB2.Name)
WB2.Close savechanges:=False
Next Idx
End Sub
I get a
Type Mismatch Error "13"
with the below code. Can anyone assist with where I'm going wrong with my VBA syntax and use of variables.
If Application.WorksheetFuntion.CountIf(Target, r.Value) > 1 Then
I've tried the matchFoundIndex code method to no success...Likely due to incorrect VBA syntax.
The intent of the CountIf line is to look for duplicates in column A. The rest of the code loops through files and worksheets copying the file name, worksheet name, and cell C1 for further analysis. I am a novice at coding and I'm sure there may be Dimmed variables that I'm not using, other formatting, and errors that I have not found yet. Any Help would be appreciative.
Sub CopyFileAndStudyName()
Dim sPath As String, SName As String
Dim xlWB As Workbook
Dim sh As Worksheet
Dim lngRow As Long
Dim lngwsh As Long
Dim xlApp As Excel.Application
Dim sfile As String
Dim wbk As Workbook
Dim iCntr As Long
Dim matchFoundIndex As Long
Dim FindDuplicates As Boolean
Dim IsDup As Boolean
sPath = "C:\Users\mypath\"
' which row to begin writing to in the activesheet
lngRow = 2
SName = Dir(sPath & "*.xlsx") ' for xl2007 & "*.xls"
Set xlApp = New Excel.Application
xlApp.Visible = False
If MsgBox("Are you sure you want to copy all the file and Cell C1 in " & sPath & "?", vbYesNo) = vbNo Then Exit Sub
Do While SName <> ""
lngwsh = 1
' Will cycle through all .xlsx files in sPath
Set xlWB = xlApp.Workbooks.Open(sPath & SName, , True) ' opens in read-only mode
' Will cycle through first 3 of the worksheets in each file copying file name and cell C1 in columns C and D
For lngwsh = 1 To 3
Set sh = ActiveSheet
sh.Cells(lngRow, "A") = xlWB.Name
sh.Cells(lngRow, "B") = xlWB.Worksheets(lngwsh).Range("C1")
sh.Cells(lngRow, "C") = xlWB.Sheets(lngwsh).Name
Dim Target As Range
Dim r As Range
Dim lastRow As Long
Dim ws As Worksheet
Set ws = xlWB.Worksheets(lngwsh)
With ws
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Target = ws.Range("A1:A" & lastRow)
End With
For Each r In Target
If r.Value <> "" Then
If Application.WorksheetFunction.CountIf(Target, r.Value) > 1 Then
FindDuplicates = True
Exit For
Else
FindDuplicates = False
End If
End If
Next r
Debug.Print FindDuplicates
IsDup = FindDuplicates
sh.Cells(lngRow, "D") = IsDup
FindDuplicates = False
End If
lngRow = lngRow + 1
Next lngwsh
xlWB.Close False
xlApp.Quit
SName = Dir()
Loop
MsgBox "Report Ready!"
End Sub
If you want to check for Duplicates in a Range, you can use a Dictionary object.
Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
For Each r In Target
If Trim(r.Value) <> "" Then
If Not Dict.exists(r.Value) Then ' not found in dictionary >> add Key
Dict.Add r.Value, r.Value
FindDuplicates = False
Else ' found in Dictionary >> Exit
FindDuplicates = True
Exit For
nd If
End If
Next r
Sub CopyFileAndStudyName()
Dim sPath As String, SName As String
Dim xlWB As Workbook
Dim sh As Worksheet
Dim lngRow As Long
Dim lngwsh As Long
Dim xlApp As Excel.Application
Dim sfile As String
Dim wbk As Workbook
Dim iCntr As Long
Dim matchFoundIndex As Long
Dim FindDuplicates As Boolean
Dim IsDup As Boolean
sPath = "C:\Users\mypath\"
' which row to begin writing to in the activesheet
lngRow = 2
SName = Dir(sPath & "*.xlsx") ' for xl2007 & "*.xls"
Set xlApp = New Excel.Application
xlApp.Visible = False
If MsgBox("Are you sure you want to copy all the file and Cell C1 in " & sPath & "?", vbYesNo) = vbNo Then Exit Sub
Do While SName <> ""
lngwsh = 1
' Will cycle through all .xlsx files in sPath
Set xlWB = xlApp.Workbooks.Open(sPath & SName, , True) ' opens in read-only mode
' Will cycle through first 3 of the worksheets in each file copying file name and cell C1 in columns C and D
For lngwsh = 1 To 3
Set sh = ActiveSheet
sh.Cells(lngRow, "A") = xlWB.Name
sh.Cells(lngRow, "B") = xlWB.Worksheets(lngwsh).Range("C1")
sh.Cells(lngRow, "C") = xlWB.Sheets(lngwsh).Name
Dim Target As Range
Dim r As Range
Dim lastRow As Long
Dim ws As Worksheet
Set ws = xlWB.Worksheets(lngwsh)
With ws
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Target = ws.Range("A1:A" & lastRow)
End With
For Each r In Target
If r.Value <> "" Then
If Application.WorksheetFunction.CountIf(Target, r.Value) > 1 Then
FindDuplicates = True
Exit For
Else
FindDuplicates = False
End If
End If
Next r
Debug.Print FindDuplicates
IsDup = FindDuplicates
sh.Cells(lngRow, "D") = IsDup
FindDuplicates = False
lngRow = lngRow + 1
Next lngwsh
xlWB.Close False
xlApp.Quit
SName = Dir()
Loop
MsgBox "Report Ready!"
End Sub
I was having a similar experience using CountIF and passing it a range. In my case I was using:
i = Application.WorksheetFunction.CountIf(ws.UsedRange, r.Value)
which was giving me a Type Mismatch error. I had seen other people having success with the first parameter wrapped in Range() so after a few tries I found out that this would work:
i = Application.WorksheetFunction.CountIf(Range(ws.UsedRange.Address), r.Value)
So, I suggest that you change your code to this and see if it works:
If Application.WorksheetFuntion.CountIf(Range(Target.Address), r.Value) > 1 Then
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.
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