Self creating workbook with automatic save in new created folder - excel

I have an Excel form that I need really often with other file names and changed data in the forms. I need to write code that creates a folder and saves the Excel file in it with the changed text in the form. (the text is in another Excel file)
What I have:
I have an Excel file with a list of names, numbers and text that I need to fill in my empty form.
I have a form where I have to write that stuff in, at the moment manually.
I know how I could get my data in my form, but I don't know how I can change the data so it kinda loops through and saves it.
I know how to save an Excel file but I'm not sure if its the best way, because I don't need any macros in the freshly saved form.
The end result should be that all the Excel forms get saved in a path that the user decides or where the Excel macro file is in. The Excel files should be in a folder that has the same name as the form.
Plese help me with ideas how I can realise this.
I found this code to create folders but I'm not sure how I could bind it in that it saves only the files in that have the same name.
Sub MakeFolders()
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count
For c = 1 To maxCols
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c
End Sub

Related

VBA code that allows multiple users to write to a consolidated .xlsm SharePoint file at the same time

Scenario
I have a template .xlsm file that will be shared to multiple users (~200), asking for some information from them. Once they finish filling in the information, they should be able to click on a "save" macro in their copy of the template that will copy the information they filled to a central .xlsm file stored in SharePoint.
My knowledge of VBA is limited, so the way I came up with to do this is to create a predefined database, where each user will have a predefined number of rows for his information to be stored, this way I'll avoid users overwriting each other's content in case they use the "save" macro at the same time.
Problem
So far, the code worked for a single instance of the "save" macro trying to access the database, however when I tried to run the macro from different computers at the same time (to simulate different users using the "save" macro in the same moment) only the information of one of the users got saved.
Question
My first question is if what I'm trying to do is possible (multiple instances of a VBA code opening and making changes to an online file at the same time, from different computers)?
If it is, my second question would be how I should correct my code to ensure that the changes from multiple users who accessed the file at same time gets saved.
If what I'm trying to do isn't possible, then my question would be if there's a better way to approach this problem.
Thanks
Code
Here's the barebones version of the code I'm running:
Sub Save()
Dim str_from_district, str_from_regional, str_from_DN, str_from_name As String 'Strings that the users chooses in their template to identify their position in the database
Dim rng_from_TD_rows, rng_from_product_list, rng_from_ref_TD As Range 'Data I'll copy into the database
Dim wb_to As Workbook 'workbook stored in sharepoint
Dim rng_to_district, anchor_to As Range 'position references to identify where in the database workbook the data should be stored
Dim cell As Range
Dim i, j, k As Long
'load the identifier string with the information the user selected
str_from_district = Range("District").Value2
str_from_regional = Range("Regional").Value2
str_from_DN = Range("DN").Value2
str_from_name = Range("Name").Value2
'set up the references in the user's workbook for the data that I'll copy
Set rng_from_TD_rows = Sheets("Sheet 1").Range("Table13[ID]")
Set rng_from_product_list = Sheets("Sheet 2").Range("Table3[Product]")
Set rng_from_ref_TD = Sheets("Sheet 1").Range("W1")
'Open the database workbook in sharepoint
Set wb_to = Application.Workbooks.Open("PATH/workbook.xlsm")
Set rng_to_district = wb_to.Sheets("Database").Range("Table2[District]")
wb_to.Sheets("Database").Protect Password:="", UserInterfaceOnly:=True, AllowFiltering:=True
'Find anchor point for within the master database based on the information the user selected in his workbook
For i = 1 To rng_to_district.Count
If (rng_to_district(i, 1) = str_from_district And rng_to_district(i, 0) = _
str_from_regional) And rng_to_district(i, -1) = str_from_DN Then
Set anchor_to = rng_to_district.Cells(i, 2)
Exit For
End If
Next i
Range(anchor_to(1, 1).Address & ":" & anchor_to(7, 100).Address).ClearContents
'Cycles through the information typed in by the user in his workbook and paste it into the sharepoint database workbook
k = 1
For i = 1 To rng_from_TD_rows.Count
For j = 1 To rng_from_product_list.Count * 2
If (rng_from_ref_TD(1, j) = 0) And (rng_from_ref_TD(i + 9, j) > 0) Then
anchor_to(k, 1) = str_from_name
anchor_to(k, 2) = rng_from_TD_rows(i, 1)
anchor_to(k, 3) = rng_from_TD_rows(i, 2)
anchor_to(k, 4) = rng_from_TD_rows(i, 3)
anchor_to(k, 5) = rng_from_TD_rows(i, 4)
anchor_to(k, 6) = rng_from_TD_rows(i, 5)
anchor_to(k, 7) = rng_from_ref_TD(2, j)
anchor_to(k, 8) = rng_from_ref_TD(i + 9, j + 1)
anchor_to(k, 9) = rng_from_ref_TD(i + 9, j)
k = k + 1
End If
Next j
Next i
wb_to.Close SaveChanges:=True
End Sub
The code worked when only a single instance of it was accessing the online database and copying the data into it.
However, when I tried to run the code from more than one computer at the same time, only the data from one of the computers got saved into the database.
No errors happened on the computers for which the data didn't get saved, the code simply finished running and the data was not in the database. However, if I ran the code again, this time without other instances trying to access the database, the data got saved.

Saving Range from excel-sheet to text file [duplicate]

I need to save an active range of texts to a .txt file.
The range is a column F within the worksheet called "Reports". The number of rows depends on how many rows the report generates. This column F contains email addresses, which we need to upload to another system via a .txt file.
In the .txt file, each address will be located in a different line without other delimiters.
I have code, but it leaves the first line of the text file blank, starting with the second line.
Sub Macro_Newsletter()
Dim c As Range
Dim r As Range
Dim output As String
For Each r In Worksheets("Reports").Range("F2:F10000").Rows
For Each c In r.Cells
output = output & vbNewLine & c.Value
Next c
Next r
Open "C:\Users\joseph.lin\Desktop\Database\Newsletter" For Output As #1
Print #1, output
Close
End Sub
I only know how to output them to outlook. Please help me figure out how to do this using VBA.
This will do the trick:
Sub Macro_Newsletter()
Dim wbText As Workbook
Dim wsReports As Worksheet
Set wbText = Workbooks.Add
Set wsReports = ThisWorkbook.Worksheets("Reports")
With wsReports
Dim lRow As Long
lRow = .Range("F" & .Rows.Count).End(xlUp).Row 'get last row of emails
.Range("F2:F" & lRow).Copy wbText.Sheets(1).Range("A1")
End With
'turn off alerts so you don't see messages about compatibility and such
Application.DisplayAlerts = False
With wbText
.SaveAs Filename:="C:\Users\joseph.lin\Desktop\Database\Newsletter\Emails.txt", _
FileFormat:=xlText
.Close False
End With
Application.DisplayAlerts = True
End Sub
You can simply record a macro (Developer Tab) and save it as a csv or .txt file - once you have this you can edit it as necessary. If you can save it to Outlook you should be able to save it to a text document.
This is a fairly common procedure and should be well documented within various resources.

How to stop Excel from mangling a formula inserted by my VBA script

I have a VBA script in an Excel workbook that gathers results from all the workbooks in a particular folder.
Private Sub Workbook_Open()
Dim path As String
Dim fso As Object
Dim folder As Object
Dim file As Object
Dim i As Integer
Dim data As Object
Set data = Worksheets("RawData")
path = data.Range("A1").Value
i = 3
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(path)
data.Rows("2:" & data.Rows.Count).ClearContents
For Each file In folder.Files
If Right(UCase(file.name), 5) = ".XLSX" And Left(file.name, 1) <> "~" Then
data.Cells(i, 2) = "='" + path + "\[" + file.name + "]Summary'!A1:J1"
i = i + 1
End If
Next file
End Sub
The idea is for each .xlsx file in a given folder, I add a reference to the results range in that file. For example, if there is a file Test1.xlsx in folder C:\Sheets, the VBA puts the following formula into some row on the sheet containing the script:
='C:\Sheets\[Test1.xlsx]Summary'!A1:J1
Excel then pulls values out of Test1 and puts them in the current workbook's RawData sheet.
This worked until today, when my formulas started ending up with # right after the = sign, like this:
=#'C:\Sheets\[Test1.xlsx]Summary'!A1:J1
This gives me a #VALUE?.
Excel helpfully gave me a message stating that it has just now started inserting # into formulas due to some syntax changes, but that it wouldn't affect calculations. I can't get this message to show up again, but that was the gist of it. Obviously it does affect calculations. If I manually remove the # from the formula, it works fine.
I have Office 365 and I guess I must have received an update recently that added this "feature" because all this used to work fine.
If I modify the VBA script to reference only a single cell, the # does not get inserted. But using a named range for the results (rather than A1:J1) still has the problem.
Anyone have any ideas for a workaround?
To avoid the # from being inserted, use the .Formula2 property of the range object.
This change has to do with the dynamic array feature of Excel O365
You could assign the formula to a variable and then remove the # from the string using the Right() function...
As the length of the string will be dynamic depending on the length of the file name, I've used the Len() function to get the full lenght of the string, then minus 2 from it to remove the = and #.
Note the = is concatenated with the Right() function when assigning the value to the cell.
Dim FormulaString as String
For Each file In folder.Files
If Right(UCase(file.name), 5) = ".XLSX" And Left(file.name, 1) <> "~" Then
FormulaString = "='" + path + "\[" + file.name + "]Summary'!A1:J1"
data.Cells(i, 2) = "=" & Right(FormulaString, Len(FormulaString) - 2)
i = i + 1
End If
Next file
Output is
='C:\Sheets\[Test1.xlsx]Summary'!A1:J1

Copy non adjacent data cells into one workbook

this is the code that i am currently using right now, but its not enough to meet my objectives and i am stuck on how to continue....
So this code will copy the specified data from many other excel workbook in the form of xlsx into a main excel workbook and before that it will scan through the folder which contains all the different data files and the main file(all files supposed to be transfered here in a table form) e.g. Test3.xlsx,Test4.xlsx,Test.xlxs and Main.xlsm in the folder of ScanFiles. so everytime a new files comes into the folder, it will automatically update the main workbook by opening the data workbooks then copy the required data and paste it on the main workbook upon clicking a button.
Sub ScanFiles()
Dim myFile As String, path As String
Dim erow As Long, col As Long
path = "c:\Scanfiles\"
myFile = Dir(path & "*.xlsx")
Application.ScreenUpdating = False
Do While myFile <> ""
Workbooks.Open (path & myFile)
Windows(myFile).Activate
Set copyrange = Sheets("sheet1").Range("A18,B18,C18,D18,A19,B19,C19,D19")
Windows("master-wbk.xlsm").Activate
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
col = 1
For Each cel In copyrange
cel.Copy
Cells(erow, col).PasteSpecial xlPasteValues
col = col + 1
Next
Windows(myFile).Close savechanges:=False
myFile = Dir()
Loop
Range("A:E").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Objectives: 1st:orignal type of file is in "file" not xlsx, so hope to find a way to open the file in xlsx format automatically before start of copying data.
2nd: requires 3 types of specified data e.g. name,surname(both of them are in fixed position always in A18 to D18 and A19 to D19 , 3rd one is to find the date, however the date is almost always in different positions in the data sheet, so i hope to add on a part to the code that makes it search for something like "ended 20190808" it will always start with ended but will always be in diff rows or even columns. i also need to arrange the data according to the date from newest(top) to oldest(bottom) and state the month of the date in words instead of numbers e.g. june
Deeply Appreciate any form of help but if possible the small section of code that can add on to my coding will make it a lot easier because im tasked to do this in a very limited amount of time
Thank you!!!
Here's some code that does similar things to what you describe. The animated .gif shows it working by stepping through the code. First the 2 data (.xlsx) files are shown so you have an idea of their content. Each is located in the same folder as the main workbook and has data in column A. Then as we step through the code each file is opened, its data manipulated (row 3 is deleted) and transferred into adjacent columns of the main workbook. The code is not limited to .xlsx files and will work with text files as well, as long as ext is defined.
Hopefully, once you understand how this works you can modify it to apply it to your case.
Option Explicit
Sub CombineFiles()
Dim theDir As String, numFiles As Integer
Dim sh As Worksheet, wk As Workbook, newSheet As Worksheet
Dim newColumn As Range, r As Range, s As String
Const ext = ".xlsx"
Err.Clear
theDir = ThisWorkbook.Path
Set newSheet = ThisWorkbook.Sheets.Add
newSheet.Name = "Combined"
Set newColumn = newSheet.Range("A1")
'Loop through all files in directory
s = Dir(theDir & "\*" & ext)
While s <> ""
numFiles = numFiles + 1
On Error Resume Next
Set wk = Workbooks.Open(theDir & "\" & s)
Set sh = ActiveSheet
sh.Rows(3).Delete Shift:=xlUp
Set r = Range("A1")
Range(r, r.End(xlDown)).Copy
newSheet.Activate
newColumn.Offset(0, numFiles) = wk.Name
newColumn.Offset(1, numFiles).Select
newSheet.Paste
Application.DisplayAlerts = False
wk.Close False
Application.DisplayAlerts = True
s = Dir()
Wend
MsgBox (numFiles & " files were processed.")
End Sub
For copy/paste of pictures see examples on this or this page. To find the last cell containing data in a column see this page; note that one example involves using the .find command. More generally, to learn how to use .find in vba, use the macro recorder and then adjust the resulting code.

How to export CSV file encoded with "Unicode"

Currently i using VBA code to export range data to a CSV file:
Sub Fct_Export_CSV_Migration() Dim Value As String Dim size As Integer
Value = ThisWorkbook.Path & "\Export_Migration" & Sheets(1).range("B20").Value & ".csv" chemincsv = Value
Worksheets("Correspondance Nv Arborescence").Select Dim Plage As Object, oL As Object, oC As Object, Tmp As String, Sep$ Sep = ";" size = Worksheets("Correspondance Nv Arborescence").range("B" & Rows.Count).End(xlUp).Row Set Plage = ActiveSheet.range("A1:B" & size)
Open chemincsv For Output As #1 For Each oL In Plage.Rows
Tmp = ""
For Each oC In oL.Cells
Tmp = Tmp & CStr(oC.Text) & Sep
Next
'take one less than length of the string number of characters from left, that would eliminate the trailing semicolon
Tmp = Left(Tmp, Len(Tmp) - 1)
Print #1, Tmp Next Close
MsgBox "OK! Export to " & Value End Sub
Now, i would like to export CSV encoded with "Unicode". I think i need to use VBA function like SaveAs( xlUnicodeText ) but how to use that ?
Thx
Unicode CSVs are not one of the file formats supported by Excel, out of the box. This means we cannot use the SaveAs method. The good news we can work around this restriction, using VBA.
My approach uses the file system object. This incredibly handy object is great for interacting with the file system. Before you can use it you will need to add a reference:
From the VBA IDE click Tools.
Click References...
Select Windows Script Host Object Model from the list.
Press OK.
The code:
' Saves the active sheet as a Unicode CSV.
Sub SaveAsUnicodeCSV()
Dim fso As FileSystemObject ' Provides access to the file system.
Dim ts As TextStream ' Writes to your text file.
Dim r As Range ' Used to loop over all used rows.
Dim c As Range ' Used to loop over all used columns.
' Use the file system object to write to the file system.
' WARNING: This code will overwrite any existing file with the same name.
Set fso = New FileSystemObject
Set ts = fso.CreateTextFile("!!YOUR FILE PATH HERE.CSV!!", True, True)
' Read each used row.
For Each r In ActiveSheet.UsedRange.Rows
' Read each used column.
For Each c In r.Cells
' Write content to file.
ts.Write c.Value
If c.Column < r.Columns.Count Then ts.Write ","
Next
' Add a line break, between rows.
If r.Row < ActiveSheet.UsedRange.Count Then ts.Write vbCrLf
Next
' Close the file.
ts.Close
' Release object variables before they leave scope, to reclaim memory and avoid leaks.
Set ts = Nothing
Set fso = Nothing
End Sub
This code loops over each used row in the active worksheet. Within each row, it loops over every column in use. The contents of each cell is appended to your text file. At the end of each row, a line break is added.
To use; simply replace !!YOUR FILE PATH HERE.CSV!! with your file name.

Resources