I have around 950 .xml files in a directory. I can open the .xml files with Excel without any issues. But I'd like to convert all files individually to .xls (or .csv). I searched the forum and found a few answers (see e.g. here and here) but could not make it work so far.
The closest I got to what I need is the following code:
Sub xmltoxl()
Dim f As String
Dim wbk As Workbook
Dim s As Integer
Dim tBook As Workbook
Dim MySht As Worksheet
Set tBook = ThisWorkbook
Set MySht = tBook.Sheets(1)
MySht.Cells.ClearContents
f = Dir("C:\Users\Kanye\Downloads" & "\*.xml")
s = 0
Do While Len(f) > 0
Set wbk = Workbooks.OpenXML("C:\Users\Kanye\Downloads" & "\" & f)
If s = 0 Then
wbk.Sheets(1).Cells.Copy Destination:=MySht.Cells
LastRow = MySht.Range("A" & Rows.Count).End(xlUp).Row
MySht.Range("Z1:Z" & LastRow) = f
Else
LastRow = MySht.Range("A" & Rows.Count).End(xlUp).Row
NextRow = LastRow + 1
wbkLastRow = wbk.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
wbk.Sheets(1).Rows("1:" & wbkLastRow).Copy Destination:=MySht.Rows(NextRow)
NewLastRow = MySht.Range("A" & Rows.Count).End(xlUp).Row
MySht.Range("Z" & NextRow & ":Z" & NewLastRow) = f
End If
MySht.Columns("Z").Cut
MySht.Columns("A").Insert
s = s + 1
wbk.SaveAs Filename:="C:\Users\Kanye\Downloads\Test" & s & ".csv"
wbk.Close False
f = Dir()
Loop
End Sub
However, when I run it, I get back an error after the first .xml is opened in the directory. Any ideas on how to solve this?
Try this code
Sub XMLTOCSV()
Dim f As String
Dim p As String
Dim s As Integer
p = Environ("USERPROFILE") & "\Downloads" & "\"
f = Dir(p & "*.xml")
s = 0
Application.ScreenUpdating = False
Do While Len(f) > 0
s = s + 1
ConvertXMLtoCSV p & f, p & "Test" & s & ".csv"
f = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Sub ConvertXMLtoCSV(xmlFile, csvFile)
Dim xlApp As Application
Dim xlBook As Workbook
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.OpenXML(xmlFile, 2)
xlBook.SaveAs csvFile, 6
xlBook.Close False
xlApp.Quit
End Sub
I've found the most effective method of Workbook.SaveAs is to ignore any extension and let the FileFormat argument choose that for you.
...
wbk.SaveAs Filename:="C:\Users\Kanye\Downloads\Test" & s, fileformat:=xlcsv
wbk.Close savechanges:=False
...
Related
I have 2 questions with my coding. Please bear with me since I'm not an expert on this.
Ws2.range("B6:Y" & lrow1).copy - doesn't seem to work the way I wanted it to be. It copies cells only from B1:Y6 but the intention is to copy cells starting ffrom B6:Y until the last row.
Dir Do while loops only on one file even though I have multiple files on the specified folder path. Thus, creating an infinite loop.
Any idea on what am I doing wrong?
Private Sub conso()
Dim folder As String, consofolder As String
Dim files As String, consofile As String
Dim dateyear As String, team As String
Dim strfile As String, newdate As String
Dim wb1 As Workbook, wb2 As Workbook
Dim lrow1 As Long, lrow2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet
dateyear = Range("A2").Value
newdate = Format(dateyear, "mmmm yyyy")
team = Range("B2").Value
folder = Range("C2").Value
consofolder = folder & newdate & "\" & team
consofile = "conso "
files = Dir(consofolder & "\*.xlsm")
strfile = consofolder & "\" & consofile & team & " - " & newdate & ".xlsm"
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.AutomationSecurity = msoAutomationSecurityLow
Workbooks.Open Filename:=folder & "\" & "conso conso" & ".xlsm"
Set wb1 = Workbooks("conso conso.xlsm")
wb1.Activate
Set ws1 = wb1.Worksheets("Input")
If Len(Dir(strfile)) = 0 Then
GoTo conso
Else
MsgBox "Conso already in place"
Exit Sub
End If
conso:
Do While files <> ""
Debug.Print files
Workbooks.Open Filename:=consofolder & "\" & files
Set wb2 = Workbooks(files)
Set ws2 = wb2.Worksheets("Input")
With wb2
With Worksheets("Input")
lrow1 = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
End With
ws2.Range("B6:Y" & lrow1).Copy
wb1.Activate
With wb1
With Worksheets("Input")
lrow2 = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
End With
ws1.Range("B" & lrow2).PasteSpecial
wb2.Close
files = Dir(consofolder & "\*.xlsm")
Set wb2 = Nothing
Loop
End Sub
VBA code not looping through the folder of .csv's
The code below is doing the function I need but is not looping and it would be good to add a line to delete the .csv's once copied
Option Explicit
Private Sub SaveAs_Files_in_Folder()
Dim CSVfolder As String, XLSfolder As String
Dim CSVfilename As String, XLSfilename As String
Dim template As String
Dim wb As Workbook
Dim wbm As Workbook 'The template I want the data pasted into
Dim n As Long
CSVfolder = "H:\Case Extracts\input" 'Folder I have the csv's go
XLSfolder = "H:\Case Extracts\output" 'Folder for the xlsx output
If Right(CSVfolder, 1) <> "\" Then CSVfolder = CSVfolder & "\"
If Right(XLSfolder, 1) <> "\" Then XLSfolder = XLSfolder & "\"
n = 0
CSVfilename = Dir(CSVfolder & "*.csv", vbNormal)
template = Dir("H:\Case Extracts\template.xlsx", vbNormal)
While Len(CSVfilename) <> 0
n = n + 1
Set wb = Workbooks.Open(CSVfolder & CSVfilename)
Range("A1:M400").Select
Selection.Copy
Set wbm = Workbooks.Open(template, , , , "Password") 'The template has a password
With wbm
Worksheets("Sheet2").Activate
Sheets("Sheet2").Cells.Select
Range("A1:M400").PasteSpecial
Worksheets("Sheet1").Activate
Sheets("Sheet1").Range("A1").Select
wbm.SaveAs Filename:=XLSfolder & CSVfilename & ".xlsx", FileFormat:=xlOpenXMLWorkbook
wbm.Close
End With
With wb
.Close False
End With
CSVfilename = Dir()
Wend
End Sub
The code works for the first .csv file I just can't get the loop to keep going through the files. It would also be good to add a line to delete the .csv's once they have been copied
Work with objects. You may want to see How to avoid using Select in Excel VBA. Declare objects for both the csv and template and work with them.
Your DIR is not working because of template = Dir("H:\Case Extracts\template.xlsx", vbNormal) which is right after CSVfilename = Dir(CSVfolder & "*.csv", vbNormal). It is getting reset. Reverse the position as shown below. Move it before the loop as #AhmedAU mentioned.
Copy the range only when you are ready to paste. Excel has an uncanny habit of clearing the clipboard. For example, I am pasting right after I cam copying the range.
Is this what you are trying? (Untested)
Option Explicit
Private Sub SaveAs_Files_in_Folder()
Dim CSVfolder As String, XLSfolder As String
Dim CSVfilename As String, XLSfilename As String
Dim wbTemplate As Workbook, wbCsv As Workbook
Dim wsTemplate As Worksheet, wsCsv As Worksheet
CSVfolder = "H:\Case Extracts\input" '<~~ Csv Folder
XLSfolder = "H:\Case Extracts\output" '<~~ For xlsx output
If Right(CSVfolder, 1) <> "\" Then CSVfolder = CSVfolder & "\"
If Right(XLSfolder, 1) <> "\" Then XLSfolder = XLSfolder & "\"
XLSfilename = Dir("H:\Case Extracts\template.xlsx", vbNormal)
CSVfilename = Dir(CSVfolder & "*.csv")
Do While Len(CSVfilename) > 0
'~~> Open Csv File
Set wbCsv = Workbooks.Open(CSVfolder & CSVfilename)
Set wsCsv = wbCsv.Sheets(1)
'~~> Open Template file
Set wbTemplate = Workbooks.Open(XLSfolder & XLSfilename, , , , "Password")
'~~> Change this to relevant sheet
Set wsTemplate = wbTemplate.Sheets("Sheet1")
'~~> Copy and paste
wsCsv.Range("A1:M400").Copy
wsTemplate.Range("A1").PasteSpecial xlPasteValues
'~~> Save file
wbTemplate.SaveAs Filename:=XLSfolder & CSVfilename & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook
'~~> Close files
wbTemplate.Close (False)
wbCsv.Close (False)
'~~> Get next file
CSVfilename = Dir
Loop
'~~> Clear clipboard
Application.CutCopyMode = False
End Sub
I think must be something like this, adapted to very fast looping through huge of csvs files
reference “Microsoft Scripting Runtime” (Add using
Tools->References from the VB menu)
Sub SaveAs_Files_in_Folder()
Dim myDict As Dictionary, wb As Workbook, eachLineArr As Variant
Set myDict = CreateObject("Scripting.Dictionary")
CSVfolder = "H:\Case Extracts\input\"
XLSfolder = "H:\Case Extracts\output\"
Template = ThisWorkbook.path & "\template.xlsx"
fileMask = "*.csv"
csvSeparator = ";"
csvLineBreaks = vbLf ' or vbCrLf
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.Calculation = xlManual
'.Visible = False ' uncomment to hide templates flashing
End With
LookupName = CSVfolder & fileMask
Results = CreateObject("WScript.Shell").Exec("CMD /C DIR """ & LookupName & Chr(34) & " /S /B /A:-D").StdOut.ReadAll
filesList = Split(Results, vbCrLf)
For fileNr = LBound(filesList) To UBound(filesList) - 1
csvLinesArr = Split(GetCsvFData(filesList(fileNr)), csvLineBreaks) ' read each csv to array
ArrSize = UBound(Split(csvLinesArr(lineNr), csvSeparator))
For lineNr = LBound(csvLinesArr) To UBound(csvLinesArr)
If csvLinesArr(lineNr) <> "" Then
eachLineArr = Split(csvLinesArr(lineNr), csvSeparator) ' read each line to array
ReDim Preserve eachLineArr(ArrSize) ' to set first line columns count to whoole array size
myDict.Add Dir(filesList(fileNr)) & lineNr, eachLineArr ' put all lines into dictionary object
End If
Next lineNr
Set wb = Workbooks.Open(Template, , , , "Password")
wb.Worksheets("Sheet1").[a1].Resize(myDict.Count, ArrSize) = TransposeArrays1D(myDict.Items)
Set fso = CreateObject("Scripting.FileSystemObject")
csvName = fso.GetBaseName(filesList(fileNr))
Set fso = nothing
wb.SaveAs FileName:=XLSfolder & csvName & ".xlsx"
wb.Close
Set wb = Nothing
Next fileNr
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = xlManual
.Visible = True
End With
End Sub
Function GetCsvFData(ByVal filePath As String) As Variant
Dim MyData As String, strData() As String
Open filePath For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
GetCsvFData = MyData
End Function
Function TransposeArrays1D(ByVal arr As Variant) As Variant
Dim tempArray As Variant
ReDim tempArray(LBound(arr, 1) To UBound(arr, 1), LBound(arr(0)) To UBound(arr(0)))
For y = LBound(arr, 1) To UBound(arr, 1)
For x = LBound(arr(0)) To UBound(arr(0))
tempArray(y, x) = arr(y)(x)
Next x
Next y
TransposeArrays1D = tempArray
End Function
I am a bit stuck with finishing the script below.
I got to this point and it does the basic thing I need it to do but it does need a bit of tweaking to get perfect.
It does the following: 1-pickup and prep master output file; 2- open each file in folder 'xls' and copy data from the designated sheet at the end of the master output file; 3-final edit of the master file; 4-save master file with name based on the input archives.
Where I need help is and was unable to fix up is: I want the script to cycle through subfolders in 'xls' folder and create a single master for each subfolder in 'xls' collecting data from files in that subfolder and name it after subfolder.
I understand I need another loop for subfolders but I am not really good with dirs in vba. Would this require a major overhaul?
Sub Joiner()
'Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim FileNAME As String
Dim wb As Workbook
Dim Masterwb As Workbook
Dim sh As Worksheet
Dim NewSht As Worksheet
Dim FindRng As Range
Dim PasteRow As Long
Dim DayVar As String
Dim RangeVar As Variant
Dim LastRow As Long
Dim Targetsh As Worksheet
Dim RecordsCount As Long
' set master workbook
Workbooks.Open FileNAME:="C:\TA\output\Master Template.xlsx"
Set Masterwb = Workbooks("Master Template.xlsx")
Set Targetsh = Masterwb.Sheets("Data")
With ActiveWorkbook.Sheets("Data")
.Range("A1").FormulaR1C1 = "SysTime"
.Range("B1").FormulaR1C1 = "Seq#"
.Range("C1").FormulaR1C1 = "A1"
.Range("D1").FormulaR1C1 = "F2"
.Range("E1").FormulaR1C1 = "F3"
.Range("F1").FormulaR1C1 = "T4"
.Range("G1").FormulaR1C1 = "T5"
.Range("H1").FormulaR1C1 = "T6"
.Range("I1").FormulaR1C1 = "T7"
.Range("J1").FormulaR1C1 = "T8"
.Range("K1").FormulaR1C1 = "A9"
.Range("A1:K1").Font.Bold = True
.Range("A1:K1").Interior.ColorIndex = 19
.Range("L1").FormulaR1C1 = "Date"
.Range("M1").FormulaR1C1 = "Date/Seq#"
End With
folderPath = "C:\TA\xls\" 'contains folder path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
Application.ScreenUpdating = False
FileNAME = Dir(folderPath & "*.xls*")
Do While FileNAME <> ""
Set wb = Workbooks.Open(folderPath & FileNAME)
'DayVar = Left(Right(wb.Name, 13), 8)
LastRow = wb.Sheets("Cleaned").Range("A1").End(xlDown).Row
RangeVar = wb.Sheets("Cleaned").Range("A2:K" & LastRow)
Targetsh.Range("A" & Rows.Count).End(xlUp)(2).Resize(UBound(RangeVar, 1), UBound(RangeVar, 2)) = RangeVar
wb.Close False
Exit_Loop:
Set wb = Nothing
FileNAME = Dir
Loop
Application.ScreenUpdating = True
With Masterwb.Sheets("Data")
.Range(Range("A2"), Range("A2").End(xlDown)).NumberFormat = "dd/mm/yyyy hh:mm:ss"
End With
LastRow = ActiveWorkbook.Sheets("Data").Range("A1").End(xlDown).Row
With ActiveWorkbook.Sheets("Data")
.Range("L2").FormulaR1C1 = "=INT(C1)"
.Range("M2").FormulaR1C1 = "=C12&""-""&C2"
End With
Range("L2").AutoFill Destination:=Range("L2" & ":L" & LastRow)
With ActiveSheet
.Columns("L:L").Cells = .Columns("L:L").Cells.Value
End With
Range("M2").AutoFill Destination:=Range("M2" & ":M" & LastRow)
With ActiveSheet
.Columns("M:M").Cells = .Columns("M:M").Cells.Value
End With
With Masterwb.Sheets("Data")
.Range(Range("L2"), Range("L2").End(xlDown)).NumberFormat = "dd/mm/yyyy"
End With
'Name the master output based on id
Dim FirstName As String
Dim InterName As String
Dim FinalName As String
Dim FilePath As String
FirstName = Dir("C:TA\Input\*.cab", vbNormal)
InterName = "Master Template " & Right(Left(FirstName, 12), 4)
'MsgBox FirstName
'MsgBox InterName
FilePath = "C:\TA\output"
ActiveWorkbook.SaveAs FileNAME:=FilePath & "\" & InterName & ".xlsx", _
FileFormat:=51, CreateBackup:=False
'
End Sub
Thank you for any advice.
With this code you can list excel files in a folder and subfolders
Sub ListSubfoldersFile() ' only one level subfolders
arow = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
mFolder = "F:\Download\" ' path to change
Set mainFolder = objFSO.GetFolder(mFolder)
StrFile = Dir(mFolder & "*.xls*")
Do While Len(StrFile) > 0
Cells(arow, 1).Value = mFolder & StrFile
arow = arow + 1
StrFile = Dir
Loop
For Each mySubFolder In mainFolder.subfolders
StrFile = Dir(mySubFolder & "\*.xls*")
Do While Len(StrFile) > 0
Cells(arow, 1).Value = mySubFolder & "\" & StrFile
arow = arow + 1
StrFile = Dir
Loop
Next
End Sub
Thank you Patel!
I used your solution to complement my current vba snippet.
It may be a bit clunky but it does what I need it to do.
Thank you.
Posting a solution below for the benefit of the community.
Sub MassJoiner()
'this is a version of joiner with subfolders
'Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim FileNAME As String
Dim wb As Workbook
Dim Masterwb As Workbook
Dim sh As Worksheet
Dim NewSht As Worksheet
Dim FindRng As Range
Dim PasteRow As Long
Dim DayVar As String
Dim RangeVar As Variant
Dim LastRow As Long
Dim Targetsh As Worksheet
Dim RecordsCount As Long
Dim StrFile As String
Dim mFolder As String
Dim BatchCount As Long
Dim ID As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
mFolder = "D:\TA\TEST\" ' path to change
Set mainFolder = objFSO.GetFolder(mFolder)
StrFile = Dir(mFolder & "*.xls*")
BatchCount = 0
Workbooks.Open FileNAME:="C:\TA\output\Master Template.xlsx"
For Each mySubFolder In mainFolder.subfolders
StrFile = Dir(mySubFolder & "\*.xls*")
Do While Len(StrFile) > 0
Set Masterwb = Workbooks("Master Template.xlsx")
Set Targetsh = Masterwb.Sheets("Data")
With ActiveWorkbook.Sheets("Data")
.Range("A1").FormulaR1C1 = "SysTime"
.Range("B1").FormulaR1C1 = "Seq#"
.Range("C1").FormulaR1C1 = "A1"
.Range("D1").FormulaR1C1 = "F2"
.Range("E1").FormulaR1C1 = "F3"
.Range("F1").FormulaR1C1 = "T4"
.Range("G1").FormulaR1C1 = "T5"
.Range("H1").FormulaR1C1 = "T6"
.Range("I1").FormulaR1C1 = "T7"
.Range("J1").FormulaR1C1 = "T8"
.Range("K1").FormulaR1C1 = "A9"
.Range("A1:K1").Font.Bold = True
.Range("A1:K1").Interior.ColorIndex = 19
.Range("L1").FormulaR1C1 = "Date"
.Range("M1").FormulaR1C1 = "Date/Seq# pair"
End With
'FileNAME = Dir(folderPath & "*.xls*")
'Do While FileNAME <> ""
Set wb = Workbooks.Open(mySubFolder & "\" & StrFile)
'DayVar = Left(Right(wb.Name, 13), 8)
LastRow = wb.Sheets("Cleaned").Range("A1").End(xlDown).Row
RangeVar = wb.Sheets("Cleaned").Range("A2:K" & LastRow)
Targetsh.Range("A" & Rows.Count).End(xlUp)(2).Resize(UBound(RangeVar, 1), UBound(RangeVar, 2)) = RangeVar
wb.Close False
'Exit_Loop:
' Set wb = Nothing
' FileNAME = Dir
'Loop
StrFile = Dir
Loop
With Masterwb.Sheets("Data")
.Range(Range("A2"), Range("A2").End(xlDown)).NumberFormat = "dd/mm/yyyy hh:mm:ss"
End With
LastRow = ActiveWorkbook.Sheets("Data").Range("A1").End(xlDown).Row
With ActiveWorkbook.Sheets("Data")
.Range("M2").FormulaR1C1 = "Date/Seq# pair"
.Range("m2").FormulaR1C1 = "=C12&""-""&C2"
End With
Range("L2").AutoFill Destination:=Range("L2" & ":L" & LastRow)
With ActiveSheet
.Columns("L:L").Cells = .Columns("L:L").Cells.Value
End With
Range("M2").AutoFill Destination:=Range("M2" & ":M" & LastRow)
With ActiveSheet
.Columns("M:M").Cells = .Columns("M:M").Cells.Value
End With
With Masterwb.Sheets("Data")
.Range(Range("l2"), Range("l2").End(xlDown)).NumberFormat = "dd/mm/yyyy"
End With
'Name the master output based on job id
Dim FirstName As String
Dim InterName As String
Dim FinalName As String
Dim FilePath As String
FirstName = mySubFolder
InterName = "Master Template " & Right(FirstName, 4)
ID = Right(FirstName, 4)
'MsgBox FirstName
'MsgBox InterName
FilePath = "C:\TA\output"
ActiveWorkbook.SaveAs FileNAME:=FilePath & "\" & InterName & ".xlsx", _
FileFormat:=51, CreateBackup:=False
ActiveWorkbook.Close False
BatchCount = BatchCount + 1
Application.Speech.Speak "Batch job" & BatchCount & "finalized. ID" & ID
Workbooks.Open FileNAME:="C:\output\Master Template.xlsx"
Next
Application.ScreenUpdating = True
End Sub
I've got a vbscript that converts a specific range of rows to a csv file.
My problem is it also copies empty rows and not needed blue rows. How can I delete this complete empty rows before copying or exclude them from copying?
My code:
Public Sub xlsToCsv()
Const WorkingDir = "C:\Test\"
Const xlCSV = 24
Const xlUp = -4162
Dim fso, SaveName, myFile
Dim objExcel, objWorkbook, wsSource, wsTarget
myFile = "source_file.xlsx"
SaveName = "test.csv"
With CreateObject("Scripting.FilesystemObject")
If Not .FileExists(WorkingDir & myFile) Then
MsgBox "File not found:" & vbCrLf & WorkingDir & myFile, vbInformation, "Script Cancelled"
WScript.Quit
End If
End With
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(WorkingDir & myFile)
Set wsSource = objWorkbook.Sheets(1)
Set wsTarget = objWorkbook.Sheets.Add()
With wsTarget
.Cells(1,1).Value = "ID"
.Cells(1,2).Value = "NAME"
.Cells(1,3).Value = "DESC"
End With
With wsSource
.Range("F7", .Range("F" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("A2")
.Range("A7", .Range("A" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("B2")
.Range("E7", .Range("E" & .Rows.Count).End(xlUp)).Copy wsTarget.Range("C2")
End With
objWorkbook.SaveAs WorkingDir & SaveName, xlCSV
objWorkbook.Close True
Set objWorkbook = Nothing
Set objExcel = Nothing
Set fso = Nothing
Set myFolder = Nothing
End Sub
call xlsToCsv()
Option explicit
'// Define the blue color here
dim ibluecolor: ibluecolor = 15652797 ' this is 40% Accent1
Public Sub xlsToCsv()
Const WorkingDir = "C:\Test\"
Const xlCSV = 24
Const xlUp = -4162
Dim fso, SaveName, myFile, myFolder
Dim objExcel, objWorkbook, wsSource, wsTarget
myFile = "source_file.xlsx"
SaveName = "test.csv"
With CreateObject("Scripting.FilesystemObject")
If Not .FileExists(WorkingDir & myFile) Then
MsgBox "File not found:" & vbCrLf & WorkingDir & myFile, vbInformation, "Script Cancelled"
WScript.Quit
End If
End With
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(WorkingDir & myFile)
Set wsSource = objWorkbook.Sheets(1)
Set wsTarget = objWorkbook.Sheets.Add()
With wsTarget
.Cells(1,1).Value = "ID"
.Cells(1,2).Value = "NAME"
.Cells(1,3).Value = "DESC"
End With
dim Fcol, Acol, Ecol
With wsSource
set Fcol = .Range("F7", .Range("F" & .Rows.Count).End(xlUp))
set Acol = .Range("A7", .Range("A" & .Rows.Count).End(xlUp))
set Ecol = .Range("E7", .Range("E" & .Rows.Count).End(xlUp))
End With
With wsTarget
Fcol.Copy .Range("A2")
Acol.Copy .Range("B2")
Ecol.Copy .Range("C2")
End With
dim Frc, Arc, Erc
Frc = Fcol.Rows.Count
Arc = Acol.Rows.Count
Erc = Ecol.Rows.Count
dim rowcount
rowcount = Max(Arc, Frc, Erc)
dim ix
with wsTarget
for ix = rowcount + 1 to 2 step -1
if Len(.cells(ix,1))=0 and len(.cells(ix,2))=0 and len(.cells(ix,3))=0 then
.rows(ix).delete
'//Check for blue rows assuming all cells in the row have the same color
elseif .cells(ix, 1).Interior.Color = iBlueColor then
.rows(ix).delete
end if
next
End With
objWorkbook.SaveAs WorkingDir & SaveName, xlCSV
objWorkbook.Close True
Set objWorkbook = Nothing
Set objExcel = Nothing
Set fso = Nothing
Set myFolder = Nothing
End Sub
call xlsToCsv()
Function Max(v1, v2, v3)
select case true
case v1 => v2 and v1 => v3
Max = v1
case v2 => v3
Max = v2
case else
Max = v3
end select
end function
This is an alternative approach to my original in an attempt to improve performance. In this case, instead of using Excel to create the csv file, the VBScript code writes the csv file directly using a text file created by FileSystemObject. I have tested this with a larger set of source data and it seems to be quite a bit quicker than the original - about 40 seconds for 1500 rows. There is still an overhead of opening the Excel application (about 5-10 seconds) but there's not much you can do about that. If performance is important to you there may be other improvements that you could do.
If you have numeric values in the spreadsheet, you may need to do some formatting to convert to string values suitable for csv output, because Excel tends to use exponential notation for numbers converted to text, which is not always what you want. I have also used quotation marks and comma separators but you could use different formatting conventions for your CSV output. You may want to change the use of WriteLine because this appends a CrLf after the last line, which might be interpreted downstream as a blank row.
Option explicit
'// Define the blue color here
dim ibluecolor: ibluecolor = 15652797 ' this is 40% Accent1
msgbox "starting"
call xlsToCsv()
msgbox "finished"
Public Sub xlsToCsv()
Const WorkingDir = "C:\Test\"
Const xlCSV = 24
Const xlUp = -4162
Dim fso, SaveName, myFile, myFolder
Dim objExcel, objWorkbook, wsSource, wsTarget
Dim oOutputFile
myFile = "source_file.xlsx"
SaveName = "test2.csv"
With CreateObject("Scripting.FilesystemObject")
'// Check that the input file exists
If Not .FileExists(WorkingDir & myFile) Then
MsgBox "File not found:" & vbCrLf & WorkingDir & myFile, vbInformation, "Script Cancelled"
WScript.Quit
End If
'// Create a text file to be the output csv file
'// Overwrite v v False=ASCII format use True for Unicode format
set oOutputFile = .CreateTextFile( WorkingDir & SaveName, True, False)
End With
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = False
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Open(WorkingDir & myFile)
Set wsSource = objWorkbook.Sheets(1)
oOutputFile.WriteLine """ID"",""NAME"",""DESC"""
'// Get the three column ranges, starting at cells in row 7
dim Fcol, Acol, Ecol
With wsSource
set Fcol = .Range("F7", .Range("F" & .Rows.Count).End(xlUp))
set Acol = .Range("A7", .Range("A" & .Rows.Count).End(xlUp))
set Ecol = .Range("E7", .Range("E" & .Rows.Count).End(xlUp))
End With
'// Get the number of rows in each column
dim Frc, Arc, Erc
Frc = Fcol.Rows.Count
Arc = Acol.Rows.Count
Erc = Ecol.Rows.Count
'// Rowcount is the max row of the three
dim rowcount
rowcount = Max(Arc, Frc, Erc)
dim AVal, FVal, EVal
dim ix
for ix = 1 to rowcount
'// Note - row 1 of each column is actually row 7 in the workbook
AVal = REPLACE(ACol.Cells(ix, 1), """", """""")
EVal = REPLACE(ECol.Cells(ix, 1), """", """""")
FVal = REPLACE(FCol.Cells(ix, 1), """", """""")
'// Check for an empty row
if Len(AVal)=0 and len(EVal)=0 and len(FVal)=0 then
'// skip this row
'// Check for a blue row
elseif ACol.cells(ix,1).Interior.Color = iBlueColor then
'// skip this row
else
'// Write the line to the csv file
oOutputFile.WriteLine """" & FVal & """,""" & AVal & """,""" & EVal & """"
end if
next
'// Close the output file
oOutputFile.Close
'// Close the workbook
objWorkbook.Close True
objExcel.Quit
'// Clean up
Set oOutputFile = Nothing
Set objWorkbook = Nothing
Set objExcel = Nothing
Set fso = Nothing
Set myFolder = Nothing
End Sub
Function Max(v1, v2, v3)
select case true
case v1 >= v2 and v1 >= v3
Max = v1
case v2 >= v3
Max = v2
case else
Max = v3
end select
end function
I am looking for help with VBA to find file names listed in an excel Column A from a folder and return the file path in Column B
The code below works, however if I would like excel to skip the row if the filename cannot be found so that the filepath results are returned in the cell directly next to the filename.
Private Sub CommandButton1_Click()
Dim sh As Worksheet, rng As Range, lr As Long, fPath As String
Set sh = Sheets(1) 'Change to actual
lstRw = sh.Cells.Find(What:="*", After:=sh.Range("A1"), LookAt:=xlWhole, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
Set rng = sh.Range("A2:A" & lstRw)
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
fPath = .SelectedItems(1)
End With
If Right(fPath, 1) <> "\" Then
fPath = fPath & "\"
End If
fwb = Dir(fPath & "*.*")
x = 2
Do While fwb <> ""
For Each c In rng
If InStr(LCase(fwb), LCase(c.Value)) > 0 Then
Worksheets("Sheet2").Range("A" & x) = fwb
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(fPath & fwb)
Worksheets("Sheet1").Range("B" & x) = f.Path
Set fs = Nothing
Set f = Nothing
x = x + 1
End If
Next
fwb = Dir
Loop
Set sh = Nothing
Set rng = Nothing
Sheets(2).Activate
End Sub
As mentioned in my comments above, use the DIR inside the range loop. See this example.
Here it won't output anything to Col B if the respective cell in Col A doesn't return anything.
Sub Sample()
Dim sh As Worksheet
Dim rng As Range
Dim i As Long, Lrow As Long
Dim fPath As String, sPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
fPath = .SelectedItems(1)
End With
If Right(fPath, 1) <> "\" Then
fPath = fPath & "\"
End If
Set sh = ThisWorkbook.Sheets("Sheet1")
With sh
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To Lrow
'~~> Check for partial match
sPath = fPath & "*" & .Range("A" & i).Value & "*.*"
If Len(Trim(Dir(sPath))) > 0 Then
.Range("B" & i).Value = Dir(sPath)
End If
Next i
End With
End Sub
Note: If you do not want a partial match then consider revising
sPath = fPath & "*" & .Range("A" & i).Value & "*.*"
to
sPath = fPath & .Range("A" & i).Value & ".*"