Save each sheet in a workbook to separate CSV files - excel

How do I save each sheet in an Excel workbook to separate CSV files with a macro?
I have an excel with multiple sheets and I was looking for a macro that will save each sheet to a separate CSV (comma separated file). Excel will not allow you to save all sheets to different CSV files.

#AlexDuggleby: you don't need to copy the worksheets, you can save them directly. e.g.:
Public Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
SaveToDirectory = "C:\"
For Each WS In ThisWorkbook.Worksheets
WS.SaveAs SaveToDirectory & WS.Name, xlCSV
Next
End Sub
Only potential problem is that that leaves your workbook saved as the last csv file. If you need to keep the original workbook you will need to SaveAs it.

Here is one that will give you a visual file chooser to pick the folder you want to save the files to and also lets you choose the CSV delimiter (I use pipes '|' because my fields contain commas and I don't want to deal with quotes):
' ---------------------- Directory Choosing Helper Functions -----------------------
' Excel and VBA do not provide any convenient directory chooser or file chooser
' dialogs, but these functions will provide a reference to a system DLL
' with the necessary capabilities
Private Type BROWSEINFO ' used by the function GetFolderName
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim X As Long, pos As Integer
bInfo.pidlRoot = 0& ' Root folder = Desktop
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
' the dialog title
Else
bInfo.lpszTitle = Msg ' the dialog title
End If
bInfo.ulFlags = &H1 ' Type of directory to return
X = SHBrowseForFolder(bInfo) ' display the dialog
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal X, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetFolderName = Left(path, pos - 1)
Else
GetFolderName = ""
End If
End Function
'---------------------- END Directory Chooser Helper Functions ----------------------
Public Sub DoTheExport()
Dim FName As Variant
Dim Sep As String
Dim wsSheet As Worksheet
Dim nFileNum As Integer
Dim csvPath As String
Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", _
"Export To Text File")
'csvPath = InputBox("Enter the full path to export CSV files to: ")
csvPath = GetFolderName("Choose the folder to export CSV files to:")
If csvPath = "" Then
MsgBox ("You didn't choose an export directory. Nothing will be exported.")
Exit Sub
End If
For Each wsSheet In Worksheets
wsSheet.Activate
nFileNum = FreeFile
Open csvPath & "\" & _
wsSheet.Name & ".csv" For Output As #nFileNum
ExportToTextFile CStr(nFileNum), Sep, False
Close nFileNum
Next wsSheet
End Sub
Public Sub ExportToTextFile(nFileNum As Integer, _
Sep As String, SelectionOnly As Boolean)
Dim WholeLine As String
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String
Application.ScreenUpdating = False
On Error GoTo EndMacro:
If SelectionOnly = True Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
Else
With ActiveSheet.UsedRange
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & CellValue & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #nFileNum, WholeLine
Next RowNdx
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
End Sub

And here's my solution should work with Excel > 2000, but tested only on 2007:
Private Sub SaveAllSheetsAsCSV()
On Error GoTo Heaven
' each sheet reference
Dim Sheet As Worksheet
' path to output to
Dim OutputPath As String
' name of each csv
Dim OutputFile As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
' ask the user where to save
OutputPath = InputBox("Enter a directory to save to", "Save to directory", Path)
If OutputPath <> "" Then
' save for each sheet
For Each Sheet In Sheets
OutputFile = OutputPath & "\" & Sheet.Name & ".csv"
' make a copy to create a new book with this sheet
' otherwise you will always only get the first sheet
Sheet.Copy
' this copy will now become active
ActiveWorkbook.SaveAs FileName:=OutputFile, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Next
End If
Finally:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Exit Sub
Heaven:
MsgBox "Couldn't save all sheets to CSV." & vbCrLf & _
"Source: " & Err.Source & " " & vbCrLf & _
"Number: " & Err.Number & " " & vbCrLf & _
"Description: " & Err.Description & " " & vbCrLf
GoTo Finally
End Sub
(OT: I wonder if SO will replace some of my minor blogging)

Building on Graham's answer, the extra code saves the workbook back into it's original location in it's original format.
Public Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
Dim CurrentWorkbook As String
Dim CurrentFormat As Long
CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
' Store current details for the workbook
SaveToDirectory = "C:\"
For Each WS In ThisWorkbook.Worksheets
WS.SaveAs SaveToDirectory & WS.Name, xlCSV
Next
Application.DisplayAlerts = False
ThisWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat
Application.DisplayAlerts = True
' Temporarily turn alerts off to prevent the user being prompted
' about overwriting the original file.
End Sub

A small modification to answer from Alex is turning on and off of auto calculation.
Surprisingly the unmodified code was working fine with VLOOKUP but failed with OFFSET. Also turning auto calculation off speeds up the save drastically.
Public Sub SaveAllSheetsAsCSV()
On Error GoTo Heaven
' each sheet reference
Dim Sheet As Worksheet
' path to output to
Dim OutputPath As String
' name of each csv
Dim OutputFile As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
' Save the file in current director
OutputPath = ThisWorkbook.Path
If OutputPath <> "" Then
Application.Calculation = xlCalculationManual
' save for each sheet
For Each Sheet In Sheets
OutputFile = OutputPath & Application.PathSeparator & Sheet.Name & ".csv"
' make a copy to create a new book with this sheet
' otherwise you will always only get the first sheet
Sheet.Copy
' this copy will now become active
ActiveWorkbook.SaveAs Filename:=OutputFile, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Next
Application.Calculation = xlCalculationAutomatic
End If
Finally:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Exit Sub
Heaven:
MsgBox "Couldn't save all sheets to CSV." & vbCrLf & _
"Source: " & Err.Source & " " & vbCrLf & _
"Number: " & Err.Number & " " & vbCrLf & _
"Description: " & Err.Description & " " & vbCrLf
GoTo Finally
End Sub

For Mac users like me, there are several gotchas:
You cannot save to any directory you want. Only few of them can receive your saved files. More info there
Here is a working script that you can copy paste in your excel for Mac:
Public Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
SaveToDirectory = "~/Library/Containers/com.microsoft.Excel/Data/"
For Each WS In ThisWorkbook.Worksheet
WS.SaveAs SaveToDirectory & WS.Name & ".csv", xlCSV
Next
End Sub

Use Visual Basic to loop through worksheets and save .csv files.
Open up .xlsx file in Excel.
Press option+F11
Insert → Module
Insert this into the module code:
Public Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
SaveToDirectory = "./"
For Each WS In ThisWorkbook.Worksheets
WS.SaveAs SaveToDirectory & WS.Name & ".csv", xlCSV
Next
End Sub
Run the module.
(i.e. Click the play button at the top and then click "Run" on the dialog, if it pops up.)
Find your .csv files in ~/Library/Containers/com.microsoft.Excel/Data.
open ~/Library/Containers/com.microsoft.Excel/Data
Close .xlsx file.
Rinse and repeat for other .xlsx files.

Please look into Von Pookie's answer, all credits to him/her.
Sub asdf()
Dim ws As Worksheet, newWb As Workbook
Application.ScreenUpdating = False
For Each ws In Sheets(Array("EID Upload", "Wages with Locals Upload", "Wages without Local Upload"))
ws.Copy
Set newWb = ActiveWorkbook
With newWb
.SaveAs ws.Name, xlCSV
.Close (False)
End With
Next ws
Application.ScreenUpdating = True
End Sub

Related

Copy data from a workbook to an existing workbook

I'm working on Excel for Mac, v16.53, with OS Catalina v10.15.7
I have an Excel workbook called SCRIPT with two sheets.
Sheet 1 has data entry areas and sheet 2 compiles those entries into a pseudo-table. The data in sheet 1 changes with every new person that is interviewed.
The data in sheet 2 is in columns A, B, H, I and J. It is non-contiguous and doesn't always have row 1 populated.
I can copy those five columns to a new csv file called Telesales-Leads-TODAY'S DATE.
The issue is when there already is a Telesales-Leads-TODAY'S DATE file.
The script is supposed to:
If Telesales-Leads-TODAY'S DATE file does not exist:
Start a new one.
Copy/paste the new SCRIPT data and save the Telesales-Leads-TODAY'S DATE file.
If a Telesales-Leads-TODAY'S DATE file does exist:
Copy the new data from the SCRIPT workbook to the first 100% empty column of the Telesales-Leads-TODAY'S DATE file.
Save the file with the same name (Telesales-Leads-TODAY'S DATE) in csv format.
It throws an error AFTER it copies the data from the SCRIPT workbook but BEFORE it has a chance to completely open the Telesales-Leads-TODAY'S DATE file.
I am using the MsgBox to debug.
Sub BackUpScriptData()
Dim strFileName As String
Dim strFileExists As String
Dim finalcolumn As Integer
Dim firstemptycolumn As Integer
Dim csvOpened As Workbook
Dim oneCell As Range
Dim myCSVFileName As String
Dim myWB As Workbook
Dim tempWB As Workbook
Dim rngToSave As Range
Dim col As String
Dim ColumnNumber As Integer
Dim ColumnLetter As String
Dim colstart As String
Dim CellAddress As String
Dim TestChar As String
Dim NumberToLetter As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
On Error GoTo err
strFileName = "/Users/XXXXXXXX/Library/Group Containers/XXXXXXXX.Office/User Content.localized/Startup.localized/Excel/" & "Telesales-Leads-" & VBA.Format(VBA.Now, "mm-dd-yyyy") & ".csv"
strFileExists = Dir(strFileName)
If strFileExists = "" Then
MsgBox strFileName & " ~~~~~~~~doesn't exist"
Set myWB = ThisWorkbook
myCSVFileName = "/Users/XXXXXXXX/Library/Group Containers/XXXXXXXX.Office/User Content.localized/Startup.localized/Excel/" & "Telesales-Leads-" & VBA.Format(VBA.Now, "mm-dd-yyyy") & ".csv"
Set rngToSave = Range("A1:B69,H1:J69")
rngToSave.Copy
Set tempWB = Application.Workbooks.Add(1)
With tempWB
.Sheets(1).Range("A1").PasteSpecial xlPasteValues
.SaveAs FileName:=myCSVFileName, FileFormat:=xlCSV, CreateBackup:=False
.Close
End With
Else
Set myWB = ThisWorkbook
Set rngToSave = Range("A1:B69,H1:J69")
rngToSave.Copy
Set csvOpened = Workbooks.Open(FileName:=strFileName)
MsgBox "csvOpened is " & csvOpened
With csvOpened
Set oneCell = Range("A1")
Do While WorksheetFunction.CountA(oneCell.EntireColumn)
Set oneCell = oneCell.Offset(0, 1)
Loop
MsgBox "oneCell.Column is " & oneCell.Column
End With
CellAddress = Cells(1, ColNum).Address
For i = 2 To Len(CellAddress)
TestChar = Mid(CellAddress, i, 1)
If TestChar = "$" Then Exit For
NumberToLetter = NumberToLetter & Mid(CellAddress, i, 1)
Next i
MsgBox "colstart is " & colstart
With csvOpened
.Sheets(1).Range(colstart & "1").PasteSpecial xlPasteValues
.SaveAs FileName:=myCSVFileName, FileFormat:=xlCSV, CreateBackup:=False
.Close
End With
End If
err: MsgBox "failed to copy."
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
The code is essentially the same for creating a new workbook or updating an existing, the only difference being the column where the data is to be pasted. As this is a csv file then UsedRange is a simple way to determine the last clear column.
Sub BackUpScriptData2()
Const FOLDER = "/Users/XXXXXXXX/Library/Group Containers/XXXXXXXX.Office/" & _
"User Content.localized/Startup.localized/Excel/"
Const PREFIX = "Telesales-Leads-"
Dim wb As Workbook, wbCSV As Workbook
Dim ws As Worksheet, rngToSave As Range
Dim colNum As Long, myCSVFileName As String
myCSVFileName = PREFIX & VBA.Format(VBA.Now, "mm-dd-yyyy") & ".csv"
' check if file exists
If Len(Dir(FOLDER & myCSVFileName)) = 0 Then
' not exists
MsgBox "'" & myCSVFileName & "'" & vbCrLf & _
"does not exist, it will be created", vbInformation, FOLDER
Set wbCSV = Workbooks.Add()
colNum = 1
Else
' exists
Set wbCSV = Workbooks.Open(FOLDER & myCSVFileName)
With wbCSV.Sheets(1).UsedRange
colNum = .Column + .Columns.Count
End With
MsgBox "'" & myCSVFileName & "'" & vbCrLf & _
"exists, it will extended from column " & colNum, vbInformation, FOLDER
End If
' copy and save
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet2")
Set rngToSave = ws.Range("A1:B69,H1:J69")
rngToSave.Copy
With wbCSV
.Sheets(1).Cells(1, colNum).PasteSpecial xlPasteValues
.SaveAs Filename:=FOLDER & myCSVFileName, FileFormat:=xlCSV, CreateBackup:=False
.Close False
End With
MsgBox "File saved to " & myCSVFileName, vbInformation, FOLDER
End Sub

VBA Save Visible Cells on Active Sheet as PDF

I have a code that works successfully but I would like to expand on it so that it only exports the visible cells. When it runs it saves the PDF as required but the PDF has lots of blank space.
Sub OrderFormHide()
Worksheets("Order Form").Unprotect "!Product1#"
'AutoFit All Columns on Worksheet
ThisWorkbook.Worksheets("Order Form").Cells.EntireRow.AutoFit
Application.ScreenUpdating = False
'Hide rows with no data requirements
Dim c As Range
For Each c In Range("A:A")
If InStr(1, c, "DELETE") Or InStr(1, c, "DELETE") Then
c.EntireRow.Hidden = True
ElseIf InStr(1, c, "") Or InStr(1, c, "") Then
c.EntireRow.Hidden = False
End If
Next
Worksheets("Order Form").Protect "!Product1#"
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim MyFile As Variant
On Error GoTo errHandler
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strDate = Format(Now(), "ddmmyyyy")
strC = Worksheets("Start Page").Range("$C$10").Value
'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
'create default name for saving file
strFile = strName & "_" & strC & "_" & strDate & ".pdf"
strPathFile = strPath & strFile
'use can enter name and
' select folder for file
MyFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
'export to PDF if a folder was selected
If MyFile <> "False" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=MyFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'confirmation message with file info
MsgBox "PDF file has been created: " _
& vbCrLf _
& MyFile
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
Application.ScreenUpdating = True
End Sub
I have used bits from previous codes I have built but I cannot figure out how I implement this change. Any assistance will be greatly appreciated.
Please, try implementing the next way. It uses a new helper sheet, copy there the discontinuous range (as continuous), export this sheet and delete it after:
Sub testExportVisibleCellsRange()
Dim sh As Worksheet, shNew As Worksheet, rngVis As Range, strPDF As String
strPDF = ThisWorkbook.path & "\testVisible.pdf"
Set sh = ActiveSheet 'use here the necessary sheet
Set rngVis = sh.UsedRange.SpecialCells(xlCellTypeVisible)
Set shNew = Worksheets.Add(After:=sh)
rngVis.Copy shNew.Range("A1")
shNew.UsedRange.EntireColumn.AutoFit
With shNew.PageSetup
.Orientation = xlPortrait
.FitToPagesWide = 1
End With
shNew.ExportAsFixedFormat Type:=xlTypePDF, fileName:=strPDF
Application.DisplayAlerts = False
shNew.Delete
Application.DisplayAlerts = True
End Sub

Fastest way to put files in a network folder / saveas or filecopy?

I want to save Excel files in both the local drive and in the network folder. Currently I am doing it with SaveAs (local) and another SaveAs (network), is it faster to do a SaveAs then FileCopy?
Code below:
Sub SaveAs()
Dim ws As Worksheet
Dim ws_console As Worksheet
Dim long_col_number As Long
Dim long_sheets_count As Long
Dim arr_sheet_names As Variant
Dim str_password As String
Dim str_datetoday As String
Dim str_datetoday_path As String
Dim str_datetoday_network_path As String
str_datetoday = Format(Date, "yyyy-mm-dd")
str_datetoday_path = "C:\Users\" & Environ("Username") & "\Desktop\Report\" & str_datetoday
str_datetoday_network_path = "\\servername\data\reports\US Reports Daily\" & str_datetoday
If Dir(str_datetoday_path, vbDirectory) = "" Then
MkDir (str_datetoday_path)
MsgBox "Making directory"
End If
If Dir(str_datetoday_network_path, vbDirectory) = "" Then
MkDir (str_datetoday_network_path)
End If
For Each ws In ThisWorkbook.Worksheets
If ws.CodeName = "AILD_01_Console" Then
Set ws_console = ws
Exit For
End If
Next ws
long_col_number = 0
For long_col_number = 1 To 8
long_sheets_count = Application.WorksheetFunction.CountA(ws_console.Range(Cells(16, long_col_number), Cells(24, long_col_number)))
arr_sheet_names = ws_console.Range(Cells(16, long_col_number), Cells(15 + long_sheets_count, long_col_number))
arr_sheet_names = Application.WorksheetFunction.Transpose(arr_sheet_names)
Worksheets(arr_sheet_names).Copy
ActiveWorkbook.SaveAs _
Filename:=str_datetoday_path & "\" & ws_console.Cells(15, long_col_number) & " - " & Format(Date, "yyyy-mm-dd"), _
FileFormat:=51
ActiveWorkbook.SaveAs _
Filename:=str_datetoday_network_path & "\" & ws_console.Cells(15, long_col_number), _
FileFormat:=51
ActiveWorkbook.Close False
Next long_col_number
ws_console.Activate
End Sub
Thank you very much for all the help.

VBA code to loop through folder of .csv files, paste data into a xlsx template and save as .xlsx

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

Search some text/word in folder containing bunch of PDF files and get count of PDF contains that text/word - Without opening pdf files

Aim - I want VBA code that should search specific text/word in content inside bunch of pdf files and give me COUNT of PDF contains that word (without opening pdf files)
Currently I have code found on internet giving me count of PDF files that contains specific text in the > Name of pdf files <
But as mentioned I want to modify below code/give me new code that should give me COUNT of pdf files contains that specific word inside the PDF content
Below is the current code I have
Sub PDFCONTENT()
Dim i As Long
Dim x As Integer
Dim Folder As String
Dim ExcelFN As String
Dim NumFiles As Integer
Dim filename As String
Dim FinsS As String
For i = 2 To Range("A" & Rows.count).End(xlDown).Row
NumFiles = 0
Folder = Sheets("Sheet1").Range("A" & i).Value
ExcelFN = Sheets("Sheet1").Range("B" & i).Value
filename = Dir(Folder & "*" & ExcelFN & "*")
Do While filename <> ""
NumFiles = NumFiles + 1
filename = Dir()
Loop
Sheets("Sheet1").Range("C" & i) = NumFiles
Next i
End Sub
I don't see how you will get the content of the PDF files, or any files for that matter, without opening the files. Also, you will need Adobe Acrobat installed to scan PDF files using VBA. I don't know how much it costs, but it's not free. If you want a free option, convert all PDF files into Word files and then do scans on those.
Sub ConvertToWord()
Dim MyObj As Object, MySource As Object, file As Variant
file = Dir("C:\Users\Excel\Desktop\test\" & "*.pdf") 'pdf path
Do While (file <> "")
ChangeFileOpenDirectory "C:\Users\Excel\Desktop\test\"
Documents.Open FileName:=file, ConfirmConversions:=False, ReadOnly:= _
False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _
"", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _
Format:=wdOpenFormatAuto, XMLTransform:=""
ChangeFileOpenDirectory "C:\Users\Excel\Desktop\test\" 'path for saving word
ActiveDocument.SaveAs2 FileName:=Replace(file, ".pdf", ".docx"), FileFormat:=wdFormatXMLDocument _
, LockComments:=False, Password:="", AddToRecentFiles:=True, _
WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False, CompatibilityMode:=15
ActiveDocument.Close
file = Dir
Loop
End Sub
Then, run this code below, in Excel.
Sub OpenAndReadWordDoc()
Rows("2:1000000").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A1").Select
' assumes that the previous procedure has been executed
Dim oWordApp As Word.Application
Dim oWordDoc As Word.Document
Dim blnStart As Boolean
Dim r As Long
Dim sFolder As String
Dim strFilePattern As String
Dim strFileName As String
Dim sFileName As String
Dim ws As Worksheet
Dim c As Long
Dim n As Long
Dim iCount As Long
Dim strSearch As String
'~~> Establish an Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err Then
Set oWordApp = CreateObject("Word.Application")
' We started Word for this macro
blnStart = True
End If
On Error GoTo ErrHandler
Set ws = ActiveSheet
r = 1 ' startrow for the copied text from the Word document
' Last column
n = ws.Range("A1").End(xlToRight).Column
sFolder = "C:\Users\Excel\Desktop\test\"
'~~> This is the extension you want to go in for
strFilePattern = "*.doc*"
'~~> Loop through the folder to get the word files
strFileName = Dir(sFolder & strFilePattern)
Do Until strFileName = ""
sFileName = sFolder & strFileName
'~~> Open the word doc
Set oWordDoc = oWordApp.Documents.Open(sFileName)
' Increase row number
r = r + 1
' Enter file name in column A
ws.Cells(r, 1).Value = sFileName
ActiveCell.Offset(1, 0).Select
ActiveSheet.Hyperlinks.Add Anchor:=Sheets("Sheet1").Range("A" & r), Address:=sFileName, _
SubAddress:="A" & r, TextToDisplay:=sFileName
' Loop through the columns
For c = 2 To n
If oWordDoc.Content.Find.Execute(FindText:=Trim(ws.Cells(1, c).Value), _
MatchWholeWord:=True, MatchCase:=False) Then
strSearch = ws.Cells(1, c).Value
iCount = 0
With ActiveDocument.Content.Find
.Text = strSearch
.Format = False
.Wrap = wdFindStop
Do While .Execute
iCount = iCount + 1
Loop
End With
ws.Cells(r, c).Value = iCount
End If
Next c
oWordDoc.Close SaveChanges:=False
'~~> Find next file
strFileName = Dir
Loop
ExitHandler:
On Error Resume Next
' close the Word application
Set oWordDoc = Nothing
If blnStart Then
' We started Word, so we close it
oWordApp.Quit
End If
Set oWordApp = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
Function GetDirectory(path)
GetDirectory = Left(path, InStrRev(path, "\"))
End Function
Here, the counts are the same because I copied/pasted the same file 4x so I had something to loop over.

Resources