Button to Save Excel range of cells (not manually selected, but automatically detected) as ".csv" with same name as original ".xls" file - vba

Here you have some information regarding my Excel file so you know better my worksheet layout:
it is a normal excel sheet (.xlsx) which starts at row 5 and has many different entries for a table.
Some of this entries are automatically calculated from a function which uses values from cells from the same row.
The document goal is to be a template, so the number of rows containing information may vary depending who is using the template.
Even though the number of rows containing information may vary the functions have to be present at all cells in a column, so whenever someone places a new entry to the table it is automatically calculated.
The formulas are all of them like this: " = if ( #cellvalue <> ""# ; #dosomething# ; #""#) ", which mainly places an empty string if no value is present in a cell, and does someting else if a value is entered.
The template will be cell protected, so only some cells would be able to be modified.
During the last days I've been trying to implement a Button for excel which does the following things on click:
Detect which rows contain table entries, but discarting the rows which contain no manually entered values and may only contain the function stated on the previous paragraph. The table always start at raw 5 but might end at row 50 or 60 or whenever the person who uses it stops to manually enter new entries to the table. It is possible that only the row 5 contains information, but it can never happen that any entry is present in the table.
Create a new ".csv" file, containing only the previously selected rows, on the same folder as the ".xlsx" file which is being used as a template. The ".csv" file name must be the same as the ".xlsx" file, but appending some information present in some specific cells (for example information present in cell A1, B1, A3, C3). The information to be appended will always be string text which will never come from a function output but from manually entered by the keypad. It could be that some of this cells contain no information (empty strings such as: "").
The button action should directly save the file in the same directory where the template is without opening a dialog to save the file. The button should also prompt a dialog in case the name being used for the ".csv" file already exists as a "filename.csv" file in the same folder. This prompted dialog should ask if you would like to overwrite the existing file with the same name with the new one.

Written without Excel on my current PC so you'll need to tinker a bit but something like this:
' Rows that contain entries:
' assuming data is in column A (i.e. col 1)
Dim rowHolderArray() as long
Dim lastRow as long
lastRow = range("A65000").End(xlUp).Row
Redim rowHolderArray(lastRow)
For x = 1 to lastRow
If cells(x,1) <> "" then rowHolderArray(x) = x
next x
2) to populate the csv, create it using the AddWorkbook method then do something like:
Dim rowCounter as long
rowCounter = 1
For x = 0 to UBound(rowHolderArray) - 1
If rowHolderArray(x) <> "" then
cells(rowCounter, 1) = rowHolderArray(x)
rowCounter = rowCounter + 1
End if
Next x
3) To save the book use Application.ActiveWorkbook.Path & "/" & yourWorkBook.name & ".xlsx"

Thanks to everyone, finally I could implement what I wanted. Here you have my example code so you can check it:
Private Sub CommandButton1_Click()
Dim i As Boolean
Dim j As Integer
Dim currentworkbook As String
Dim currentpath As String
Dim csvfilename As String
Dim contentrange As Range
Dim researchername As String
Dim projectname As String
Dim aditional_info As String
Dim year As String
Dim month As String
Dim day As String
Dim hour As String
Dim minute As String
Dim WB As Workbook
Application.DisplayAlerts = False
' Calculate which was the last row with information
i = True
j = 12
While i
j = j + 1
If (Application.Cells(j, 2) = "") Then
i = False
j = j - 1
End If
Wend
' Copy the information I wanted to save in a .csv file
Application.Range(Application.Cells(12, 1), Application.Cells(j, 16)).Copy
' Create some variables to manage the path ant some filenames
currentworkbook = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5)
currentpath = Application.ActiveWorkbook.Path
csvfilename = currentworkbook & "_"
researchername = Application.Cells(1, 2)
projectname = Application.Cells(3, 2)
aditional_info = Application.Cells(5, 2)
year = Format(Now(), "yy")
month = Format(Now(), "MM")
day = Format(Now(), "dd")
hour = Format(Now(), "Hh")
minute = Format(Now(), "Nn")
' Create a new workbook which will be filled with the information copied and then saved as a .csv file.
Set WB = Workbooks.Add
With WB
.Title = "mytitle"
.Subject = "Mysubject"
.Sheets(1).Select
ActiveSheet.Paste
.SaveAs currentpath & "\" & csvfilename & "_" & year & "-" & month & "-" & day & "_" & hour & "h" & minute & "m_" & projectname & "_" & researchername & "_" & aditional_info, xlCSV
.Close
End With
Application.DisplayAlerts = True
End Sub

Related

Get the Worksheet Name of all the .xlsx Workbooks inside a directory

I have a textbox where I am getting an Input Directory and calculating the number of .xlsx reports and the total number of worksheets in those report.
I would like to get the report name and sheetname of each of those report.
What could be the quickest way to get that.
As there are cases where it could be 100 workbooks and total of 1000 worksheets inside them.
Here goes my code which Just gets the number of reports and worksheets in those reports.
Private Sub FL_TextBox_Change()
Dim FolderPath As String
Dim path As String
Dim count As Integer
Dim Wk As Workbook
Dim Ws As Workbook
Set Ws = ActiveWorkbook
FolderPath = NewTask.FL_TextBox.Value
MsgBox ("Click Ok & Wait for the Total Number of Reports and Worksheets" & vbNewLine & vbNewLine & "to be calculated.")
If FolderPath = "" Then
NewTask.Num_Rpt_TextBox.Value = ""
Ws.Sheets("Config").Range("I1").Value = ""
Else
path = FolderPath & "\*.xlsx"
Filename = Dir(path)
File = (FolderPath & "\" & Filename)
wkcount = 0
Shcount = 0
shtcount = 0
RptSheets = ""
Do While Filename <> ""
wkcount = wkcount + 1
File = FolderPath & "\" & Filename
Set Wk = Workbooks.Open(File, ReadOnly:=True)
Shcount = Wk.Sheets.count
If RptSheets <> "" Then
RptSheets = RptSheets & "," & Shcount
Else
RptSheets = Shcount
End If
Wk.Close
shtcount = shtcount + Shcount
Filename = Dir()
Loop
Ws.Sheets("Config").Range("I1").Value = RptSheets
XlsxFilesPresent = wkcount & " / " & shtcount
NewTask.Num_Rpt_TextBox.Value = XlsxFilesPresent
End If
End Sub
So, in short - I want to get the number of .xlsx reports and those report names and number of worksheets inside those report and the worksheet names in a structured way.
Something like
Number of workbooks = 3
Number of Worksheets = 100
ReportNames = TestFile1, TestFile2, TestFile3.
SheetNames = TestFile1:TestSheet1, TestFile1:TestSheet2, TestFile1:TestSheet3, TestFile1:TestSheet4 etc.,
Kindly share your thoughts in getting this process running faster.
It seems you have everything you need, you just need to add some lines to make an object that contains all of the data you need and then you can use that object to extract anything you want and I cannot think of anything better than a dictionary object.
All of the information of the sheets are stored in a collection object called worksheets so you can simply store that object and iterate through it to access worksheet names and possibly any other information you want. So first create a collection object and a dictionary object like this:
Dim coll As Object
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Inside your do while loop use workbook names as keys and the worksheets object of that workbook as the item. Note that the keys should be unique and I assume that you will run this in one directory so file names must be unique forced by your OS.
To add keys and items inside the loop after you opened the workbook use this:
set coll=wk.Worksheets
dict.add Wk,coll
once the execution gets out of the loop you have a dictionary of all workbooks and their worksheets object. Now you can loop through the dictionary and form the data however you want. for example, let's say you want to print the workbook name and then the worksheets:
dim i as integer
dim key as variant
Dim sht As Worksheet
for each key in dict.keys
set coll=dict(key) 'sets the item of the dict=worksheets
For i = 1 To coll.Count 'loop through worksheets object and print their names
Set sht = coll(i)
Debug.Print key & ":" & sht.Name
Next
next key

VBA to copy only specific columns in excel to export as csv

trying to turn an excel worksheet into a csv with only the data I need. Basically I need to only export columns that contain data. I'm pretty new to using vba macros. I've made a worksheet with cells linked to comboboxes for the first row in columns A:AF. The problem is that it seems these combobox-linked cells are treated as data when I either try to directly save the worksheet as a csv or export using the macro further below.
Example of first (column heading/variable name) line and then an example first row of one observation that I would ideally see in the exported csv:
Author,Year,Yield,Treatment
Smith,1999,2.6,notill
Where the Author...Treatment line originally came from selections in validation list restricted cells linked to comboboxes and the Smith...notill observation is something I paste in. Example of what I see instead:
Author,Year,Yield,Treatment,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
Smith,1999,2.6,notill,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
And then all the rows of observations below that are the same number of columns across.
This creates problems since I now have new variables that mess up merges if I do getnames in SAS. I can't specify the columns, since every time this is created and then exported, there are different numbers of columns. There are ways to deal with this if the columns you want are known, eg this answer . But I want to be able to able to say either ideally "copy only the columns that aren't empty," or maybe "copy only the columns with one of the following specific text in the first row" since A2:AF2 can only contain one of 32 certain things if they're not empty.
Here is the the code I've got that copies all these blank columns to a new workbook and saves that.
Sub CopyToCSV()
Dim MyPath As String
Dim MyFileName As String
'The path and file names:
MyPath = "C:\Users\Data\TxY\"
MyFileName = "TxY_" & Sheets("ValidationHeadings").Range("D3").Value & "_" & Format(Date, "ddmmyy")
'Makes sure the path name ends with "\":
If Not Right(MyPath, 1) = "\" Then MyPath = MyPath & "\"
'Makes sure the filename ends with ".csv"
If Not Right(MyFileName, 4) = ".csv" Then MyFileName = MyFileName & ".csv"
'Copies the sheet to a new workbook:
Sheets("TxYdata").Copy
'The new workbook becomes Activeworkbook:
With ActiveWorkbook
'Saves the new workbook to given folder / filename:
.SaveAs Filename:= _
MyPath & MyFileName, _
FileFormat:=xlCSV, _
CreateBackup:=False
'Closes the file
.Close False
End With
End Sub
I know this has to be pretty simple (a column with nothing in it should stand out somehow, right?) but I searched for like 4 hours yesterday on how to do this. I would rather not demarcate the empty columns somehow in each worksheet that I am turning into a csv. Is there something I can add to
Sheets("TxYdata").Copy
to get it to only copy columns where I actually entered data, when I don't have a consistent number of columns in every sheet? Or something else that gets the job done.
Thanks so much!
Test this code.
Sub TransToCSV()
Dim vDB, vR() As String, vTxt()
Dim i As Long, n As Long, j As Integer
Dim objStream
Dim strTxt As String
Dim rngDB As Range, Ws As Worksheet
Dim MyPath As String, myFileName As String
Dim FullName As String
MyPath = "C:\Users\Data\TxY\"
myFileName = "TxY_" & Sheets("ValidationHeadings").Range("D3").Value & "_" & Format(Date, "ddmmyy")
If Not Right(MyPath, 1) = "\" Then MyPath = MyPath & "\"
If Not Right(myFileName, 4) = ".csv" Then myFileName = myFileName & ".csv"
FullName = MyPath & myFileName
Set Ws = Sheets("TxYdata")
Set objStream = CreateObject("ADODB.Stream")
With Ws
Set rngDB = .Range("a1", "d" & .Range("a" & Rows.Count).End(xlUp).Row)
'Set rngDB = .Range("a1").CurrentRegion <~~ Else use this codle
End With
vDB = rngDB
For i = 1 To UBound(vDB, 1)
n = n + 1
ReDim vR(1 To UBound(vDB, 2))
For j = 1 To UBound(vDB, 2)
vR(j) = vDB(i, j)
Next j
ReDim Preserve vTxt(1 To n)
vTxt(n) = Join(vR, ",")
Next i
strTxt = Join(vTxt, vbCrLf)
With objStream
'.Charset = "utf-8"
.Open
.WriteText strTxt
.SaveToFile FullName, 2
.Close
End With
Set objStream = Nothing
End Sub
You can approach this in different ways. Here is what I would do. Add a new sheet to your workbook. Have a FOR loop in your function to go through all columns in your sheet. For each column, you can use something like this to check if it holds any data:
iDataCount = Application.WorksheetFunction.CountIf(<worksheet object>.Range(<your column i.e. `"F:F"`>), "<>" & "")
If iDataCount is 0 then you know the column is empty. If its anything other than 0, copy it in the new sheet. Once you have complete the FOR loop, copy the new sheet into the .csv file. Finally remove the new sheet from your workbook (or you can leave it there. If you do, you just have to clear it before you run the process next time .. which can be done via the code as well)

VBA User Function Checking a Directory

Below is the code so far
I often times have to check if a Purchase Order has been saved in a directory, there could be hundreds of purchase orders listed in Excel.
As the Workbook changes, so often does the filepath.
As such, I would like to make a function that asks for a cell value that contains a string for the filepath, and then a a cell for the PO #.
I'm a little stumped on how best to past information from the Excel sheet. I need a cell reference for the filepath to the directory, and a cell reference for the PO #.
I've been able to make this work with a subroutine, that is what is posted below. This is the third VBA Program I've worked on, please let me know if there is more legwork I should do before posting this:
Dim directory As String
Dim TempfileName As String
Dim i As Long
Dim x As Long
Sub Check_PO()
x = 2
Application.ScreenUpdating = False
For x = 2 To 673
While Cells(x, 14) = 0
x = x + 1
Wend
i = Cells(x, 14)
TempfileName = "\\network\file\name\here\" & "*" & i & "*.pdf"
directory = Dir(TempfileName, vbNormal)
While directory <> ""
Cells(x, 18) = "Matched"
directory = Dir
Wend
Next x
End Sub
Here's a simple UDF:
Public Function HaveReport(fPath As String, fileName As String)
HaveReport = IIf(Dir(fPath & fileName, vbNormal) <> "", _
"Matched", "Not Matched")
End Function
Usage:

VBA Access 2010 - prompt user to pick a file and dim the filename as variable

my Access database exports a report in xls, that needs to be further reworked (some manual adjustments of columns etc. + vlookuping some comments from report from previous day).
Here is the part of the code I created so far:
Option Compare Database
Function Adjustment()
' First I want to prompt user to select the report from previous day*
Dim f As Object
Dim strFile As String
Dim strFolder As String
Dim varItem As Variant
Set f = Application.FileDialog(3)
f.AllowMultiSelect = True
If f.Show Then
For Each varItem In f.SelectedItems
strFile = Dir(varItem)
MsgBox (strFile)
Next
End If
Set f = Nothing
' here my Access database opens current report that has been exported
Dim xl As Object
Set xl = CreateObject("Excel.Application")
xl.Workbooks.Open ("I:\Temp\reports.xlsx")
xl.Visible = True
' in currently open report, I want fill cell I2 and J2 with VLOOKUP function referencing to previously selected file
Range("I2").FormulaR1C1 = "=VLOOKUP(RC7,'[" & strFile & "]SheetXY'!C7:C12,3,0)"
Range("J2").FormulaR1C1 = "=VLOOKUP(RC7,'[" & strFile & "]SheetXY!C7:C12,4,0)"
End function
Problem: I am being prompted every every time to select the file, when formula is being filled in I2 and J2, so how can I disable this and keep Access to reference strFile only once?
Question: So far, every first sheet in the refrenced workbook is called SheeyXY, but what if I would like to reference also a different Sheets (let`s say always the first sheet in the workbook no matter what its name is).
Maybe you can try this ..
Option Compare Database
Function Adjustment(SheetName as String) '---> add parameter such as "SheetXY"
' First I want to prompt user to select the report from previous day*
Dim f As Object
Dim strFolder As String
Dim varItem As Variant
Static strFile As String
If strFile = "" Then
Set f = Application.FileDialog(3)
f.AllowMultiSelect = True
If f.Show Then
For Each varItem In f.SelectedItems
strFile = Dir(varItem)
MsgBox (strFile)
Next
End If
Set f = Nothing
Endif
' here my Access database opens current report that has been exported
Dim xl As Object
Set xl = CreateObject("Excel.Application")
xl.Workbooks.Open ("I:\Temp\reports.xlsx")
xl.Visible = True
' in currently open report, I want fill cell I2 and J2 with VLOOKUP function referencing to previously selected file
Range("I2").FormulaR1C1 = "=VLOOKUP(RC7,'[" & strFile & "]" & SheetName & "'!C7:C12,3,0)"
Range("J2").FormulaR1C1 = "=VLOOKUP(RC7,'[" & strFile & "]" & SheetName & "'!C7:C12,4,0)"
End function
Have you tried taking out the .FormularR1C1 from those lines?
Also, I'm not sure exactly what you're trying to do with the sheet names, but you could probably hack something together from this?
Debug.Print Worksheets(1).Name
or
For Each ws In Worksheets
Debug.Print ws.Name
Next
UPDATE:
Try this, and report back?
With xl.Worksheets(1)
.Range("I2").FormulaR1C1 = "=VLOOKUP(RC7,[" & strFile & "]Sheet1!C7:C12,3,0)"
.Range("J2").FormulaR1C1 = "=VLOOKUP(RC7,[" & strFile & "]Sheet1!C7:C12,4,0)"
End With
So with the extra clarification of which range, and without the extra apostrophe

Get filenames FSO with comparison of filenames to sort first by specific namestructure

In the code below I could wrote a code to display filenames from a folder. The problem is now that I should display them in the correct Row. For now they are displayed in random sequence and that is not the purpose.
In column "A" the filenames to search for are called with similar name format PBM12.T5.103.
The actual filename to find is called with similar name format 1_29_PBM_12_T5__103.
I have to find a solution to compare "only" the Fat marked letters and numbers like displayed here above, without . or _
As you will see PBM12T5103 is returning in both namestructures.
Please don't try fixed length counts because the filenames are dynamic and the amount of letters are variable. The comparison of the SUBSTITUTED length of column "A" ( PBM12T5103) is the key to comparison but I can not handle to establish this comparison.
When the filename in column "A" has been found, in column "C" the full filename of found file has to be displayed as the original format 1_29_PBM_12_T5__103
Maybe a solution can be found when extra columns can be made to establish the comparison?
In Excel I could approach a solution, but this will not work automized like it should do.
I made the LEN(count dynamic), but this is still no solution to display the full filenames in the required row...
Hopefully somebody can help me out ..
Option Explicit
Sub fileNames_in_folder()
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Dim fldpath
Dim fld As Object, fil As Object, fso As Object, j As Long
fldpath = "C:\"
On Error Resume Next
Thisworkbook.Sheets("1").Activate
'start count row
j = 11
Set fso = CreateObject("scripting.filesystemobject")
Set fld = fso.getfolder(fldpath)
For Each fil In fld.Files
'here I have to add an IF statement in order to compare the filenames written in column "A" with files from folderPath C:\"
'When the correct files is found it should be displayed in column "C"
If
then
Cells(j, 34).Value = fso.GetBaseName(fil.path)
End If
'count behaviour
j = j + 1
Next
Columns("AH").AutoFit
End Sub
I will suggest you different way of getting file names. Instead of FileSystemObject let's use simple Dir function which allows to check the pattern of file name.
1) Files in my testing folder are as follows
2) I assumed that file pattern is as follows:
XXXY.Z.W
where:
XXX > 3 letters text
Y > any length number/text
Z > any length number/text
W > any length number/text
3) The code of subroutine is placed in 2013-06-01...xlsm file which you could see in the pic above (the same folder where your files are). Code is as follows (change where appropriate):
Sub solution()
Dim j As Long, LastRow As Long
Dim fldPath
'your path below
fldPath = ThisWorkbook.Path
ChDir fldPath
Dim arrPattern As Variant
Dim filName As String
For j = 1 To Range("A1").End(xlDown).Row
arrPattern = Split(Cells(j, "A"), ".")
'I suggest to use different way of checking _
pattern of file name. Pattern rules:
'*YYY*XX*Z*W*
filName = Dir("*" & Left(arrPattern(0), 3) & "*" & _
Mid(arrPattern(0), 4) & "*" & _
arrPattern(1) & "*" & _
arrPattern(2) & "*")
If Len(filName) > 0 Then
Cells(j, "B") = filName
Else
Cells(j, "B") = "not found"
End If
Next j
End Sub
4) results are presented in the picture below: