Adding individual folders to created files - excel

I have an excel file which serves as a template file, that needs to generate new files according to a list of names.
How do I save them in individual folders with the same name as the file (person's name).
This is what I have:
Sub SaveMasterAs()
Dim wb As Workbook
Dim rNames As Range, c As Range, r As Range
'Current file's list of names and ids on sheet1.
Set rNames = Worksheets("Sheet1").Range("A2", Worksheets("Sheet1").Range("A2").End(xlDown))
'Path and name to master workbook to open for copy, saveas.
Set wb = Workbooks.Open(ThisWorkbook.Path & "\template_2021.xlsm")
For Each c In rNames
With wb
.SaveAs Filename:=ThisWorkbook.Path & "\templates" & c.Value & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End With
Set wb = ActiveWorkbook
Next c
wb.Close
End Sub

I think what you want to put in your code is:
MkDir "C:\yourFolderPath"
That would create directory and then you have to save your file into it.

Copy Worksheets to Subfolders
Use variables to make the code more readable and maintainable.
Option Explicit
Sub SaveMasterAs()
Dim swb As Workbook: Set swb = ThisWorkbook
Dim sws As Worksheet: Set sws = swb.Worksheets("Sheet1")
'Current file's list of names and ids on sheet1.
Dim rNames As Range
Set rNames = sws.Range("A2", sws.Range("A2").End(xlDown))
' This is usually the preferred (safer) way:
'Set rNames = sws.Range("A2", sws.Range("A" & sws.Rows.Count).End(xlUp))
'Path and name to master workbook to open for copy, saveas.
Dim dwb As Workbook
Set dwb = Workbooks.Open(swb.Path & "\template_2021.xlsm")
Dim c As Range
Dim cString As String
Dim dFolderPath As String
Dim dFilePath As String
For Each c In rNames.Cells
cString = CStr(c.Value)
If Len(cString) > 0 Then ' not a blank cell
dFolderPath = swb.Path & "\templates\" & cString
If Len(Dir(dFolderPath, vbDirectory)) = 0 Then
MkDir dFolderPath
End With
dFilePath = dFolderPath & "\" & cString & ".xlsm"
dwb.SaveAs Filename:=dFilePath, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End If
Next c
dwb.Close SaveChanges:=False ' just in case
End Sub

Related

Copy worksheet from different workbook to this workbook reference problems

I have two Excel Files in the same folder. The macro runs on the master workbook (wb_master). It should copy the sheet from the Data Workbook (wb_Data) to wb_master.
My attempt is this:
Dim wb_name as String
Dim wb_master as Object
Dim ws_master as Object
Dim wb_Data As Object
Dim MyPath as String
Dim DataFile as String
wb_name = ActiveWorkbook.Name 'other users could have renamed the wb, so I don't want to refer to the name with a fixed string
Set wb_master = Workbooks(wb_name)
Set ws_master = wb_master.Worksheets(1)
MyPath = ActiveWorkbook.Path
DataFile = Dir(MyFolder & "\Data_*.xlsx")
Set wb_Data = Workbooks.Open(FileName:=MyPath & "\" & DataFile)
wb_Data.Sheets(1).Copy After:=wb_master.Sheets(1)
wb_Data.Close SaveChanges:=False
The problem with this is, that in the line where it copies wb_Data.Sheets(1) it doesn't use the wb_master workbook, but the wb_data workbook as destination. I assume this is because when wb_master is called, it reevaluates the ActiveWorkbook, which at this point is wb_Data.
However even though I understand, why this is happening, I can't find a solution to the problem.
Edit: This macro runs in the personal.xslb
Copy Sheet From a Closed Workbook
If you run the code from the Personal.xslb, then replace ThisWorkbook with ActiveWorkbook or the appropriate workbook e.g. Workbooks("Master.xlsm").
Option Explicit
Sub CopySheet()
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim FolderPath As String: FolderPath = dwb.Path & "\"
Dim swbName As String: swbName = Dir(FolderPath & "Data_*.xlsx")
If Len(swbName) = 0 Then Exit Sub ' file not found
Dim sFilePath As String: sFilePath = FolderPath & swbName
Dim swb As Workbook: Set swb = Workbooks.Open(sFilePath)
Dim ssh As Object: Set ssh = swb.Sheets(1)
ssh.Copy After:=dwb.Sheets(1) ' second sheet
'ssh.Copy Before:=dwb.Sheets(1) ' first sheet
'ssh.Copy After:=dwb.Sheets(dwb.Sheets.Count) ' last sheet
swb.Close SaveChanges:=False
MsgBox "Sheet copied.", vbInformation
End Sub

Copying from multiple workbooks to single workbook Excel VBA

I have multiple workbooks in a single folder. All the workbooks share the same format and I wish to copy from the same range on the first worksheet in all workbooks and add this to a single worksheet of a newly created workbook.
The code so far:
Sub OpenAllCompletedFilesDirectory()
Dim Folder As String, FileName As String
Folder = "pathway..."
FileName = Dir(Folder & "\*.xlsx")
Do
Dim currentWB As Workbook
Set currentWB = Workbooks.Open(Folder & "\" & FileName)
CopyDataToTotalsWorkbook currentWB
FileName = Dir
Loop Until FileName = ""
End Sub
Sub AddWorkbook()
Dim TotalsWorkbook As Workbook
Set TotalsWorkbook = Workbooks.Add
outWorkbook.Sheets("Sheet1").Name = "Totals"
outWorkbook.SaveAs FileName:="pathway..."
End Sub
Sub CopyDataToTotalsWorkbook(argWB As Workbook)
Dim wsDest As Worksheet
Dim lDestLastRow As Long
Dim TotalsBook As Workbook
Set TotalsBook = Workbooks.Open("pathway...")
Set wsDest = TotalsBook.Worksheets("Totals")
Application.DisplayAlerts = False
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
argWB.Worksheets("Weekly Totals").Range("A2:M6").Copy
wsDest.Range("A" & lDestLastRow).PasteSpecial
Application.DisplayAlerts = True
TotalsBook.Save
End Sub
This works - to a point. It does copy the correct ranges across and place the results one below another on the "Totals" worksheet of the "Totals" workbook, but it raises a 'Subscript out of range' error on:
argWB.Worksheets("Weekly Totals").Range("A2:M6").Copy
after data from the last workbook has been pasted.
How can I tidy this code so that it works without error?
I imagine there is scope to improve the code too.
I'd maybe do something like this.
Note you can just open the summary workbook once before looping over the files.
Sub SummarizeFiles()
'Use `Const` for fixed values
Const FPATH As String = "C:\Test\" 'for example
Const TOT_WB As String = "Totals.xlsx"
Const TOT_WS As String = "Totals"
Dim FileName As String, wbTot As Workbook, wsDest As Worksheet
'does the "totals" workbook exist?
'if not then create it, else open it
If Dir(FPATH & TOT_WB) = "" Then
Set wbTot = Workbooks.Add
wbTot.Sheets(1).Name = TOT_WS
wbTot.SaveAs FPATH & TOT_WB
Else
Set wbTot = Workbooks.Open(FPATH & TOT_WB)
End If
Set wsDest = wbTot.Worksheets(TOT_WS)
FileName = Dir(FPATH & "*.xlsx")
Do While Len(FileName) > 0
If FileName <> TOT_WB Then 'don't try to re-open the totals wb
With Workbooks.Open(FPATH & FileName)
.Worksheets("Weekly Totals").Range("A2:M6").Copy _
wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
.Close False 'no changes
End With
End If
wbTot.Save
FileName = Dir 'next file
Loop
End Sub

Save a sheet instead of a complete workbook

I am currently using following code to save an Excel workbook. Instead of saving complete work book, I just wish to save a sheet in this workbook named Reconciliation. All values in the sheet should be saved as values while keeping the formatting the same.
Sub Button3_Click()
' Yes
' Code to save consumer wise mirs on the desktop
Dim Path As String
Dim filename As String
On Error GoTo Err_Clear
Path = Environ("USERPROFILE") & "\Desktop\rohailnisar\"
filename = Range("A1")
ActiveWorkbook.SaveAs filename:=Path & filename, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Err_Clear:
If Err <> 0 Then
MkDir CreateObject("wscript.shell").specialfolders("desktop") & "\rohailnisar"
Path = Environ("USERPROFILE") & "\Desktop\rohailnisar\"
filename = Range("A1")
ActiveWorkbook.SaveAs filename:=Path & filename, FileFormat:=xlOpenXMLWorkbookMacroEnabled
End If
End Sub
Export a Worksheet
This saves a copy of a worksheet as the only sheet in a new workbook in the same folder. Before saving, it converts formulas to values. It is saved in the .xlsx format 'removing' any code.
If the code is in the open (initial) workbook, then replace ActiveWorkbook with ThisWorkbook.
Option Explicit
Sub SaveWorksheet()
On Error GoTo ClearError
Dim swb As Workbook: Set swb = ActiveWorkbook
Dim sws As Worksheet: Set sws = swb.Worksheets("Reconciliation")
Dim FolderPath As String: FolderPath = swb.Path & Application.PathSeparator
Dim BaseName As String: BaseName = sws.Range("E1").Value
Dim FilePath As String: FilePath = FolderPath & BaseName & ".xlsx"
sws.Copy
Dim dwb As Workbook: Set dwb = Workbooks(Workbooks.Count)
dwb.Worksheets(1).UsedRange.Value = dwb.Worksheets(1).UsedRange.Value
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs Filename:=FilePath, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
'dwb.Close
ProcExit:
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume ProcExit
End Sub
Instead of saving complete work book, I just wish to save a sheet in this workbook named Reconciliation. All values in the sheet should be saved as values while keeping the formatting the same.
Code
Dim wbThis As Workbook
Dim wsThis As Worksheet
Dim wbThat As Workbook
Dim wsThat As Worksheet
'~~> Change this to the workbook which has the Reconciliation sheet
Set wbThis = ThisWorkbook
Set wsThis = wbThis.Sheets("Reconciliation")
'~~> This will create a new workbook with only Reconciliation
wsThis.Copy
'~~> Get that object. It will be last in the queue
Set wbThat = Workbooks(Workbooks.Count)
Set wsThat = wbThat.Sheets("Reconciliation")
'~~> Convert to values
wsThat.UsedRange.Value = wsThat.UsedRange.Value
'~~> Save that workbook
wbThat.SaveAs Filename:=Path & Filename, FileFormat:=xlOpenXMLWorkbookMacroEnabled

How to export xls files to txt files reading them from folder (Visual Basic)?

I am trying to read files *.xls from u:\test folder. There is one sheet in every file. I want to copy cell B1 and to paste it into new file to A1. Then I want to copy range B1:B57 and to paste it into the new file/sheet to B1:B57. Then I want to copy range K1:U57 and copy (the values only) to the new file/sheet C1 location. I am doing this in Visual Basic 6 and I have problem to find out how to use the range function... I tried to activated and select the sheet(1). Then I wanted to use the command Set SrchRange = ActiveSheet.Range(Cells(2, 1)). I got error 1004 Application defined or object defined error. Here on this line. If I would successed to select/copy/paste the cell areas to new file/sheet, then I would like to save the current file as txt, given the .txt extenssion. How to correct this code to reach the goal?
Sub FromExcelToNpad()
'export activesheet as txt file
Dim my_files As String
Dim folder_path As String
Dim wb As Workbook, NewWB As Workbook
Dim ws As Worksheet
Dim SrcRange As Range
folder_path = "u:\test"
my_files = Dir(folder_path & "\*.xls", vbDirectory)
Do While my_files <> vbNullString
Set wb = Workbooks.Open(folder_path & "\" & my_files)
Set ws = wb.Sheets(1)
Set NewWB = Workbooks.Add
ws.Activate
ws.Select
Set SrchRange = ActiveSheet.Range(Cells(2, 1))
wb.ActiveSheet.UsedRange.Copy NewWB.Sheets(1).Range("A1")
wb.Close True
Application.DisplayAlerts = True
my_files = Dir()
Loop
End Sub
Update
The range and cells are copied:
Dim my_files As String
Dim folder_path As String
Dim wb As Workbook, NewWB As Workbook
Dim ws As Worksheet
folder_path = "u:\test"
my_files = Dir(folder_path & "\*.xls", vbDirectory)
Do While my_files <> vbNullString
Set wb = Workbooks.Open(folder_path & "\" & my_files)
Set ws = wb.Sheets(1)
Set NewWB = Workbooks.Add
ws.Range("B1").Copy NewWB.Sheets(1).Range("A1")
ws.Range("B3:B57").Copy NewWB.Sheets(1).Range("A3:A57")
ws.Range("K1:U57").Copy
NewWB.Sheets(1).Range("B1:L57").PasteSpecial xlValues
wb.Close True
With NewWB
Application.DisplayAlerts = False
.SaveAs Filename:=folder_path & "\" & my_files, FileFormat:=xlText
.Close True
Application.DisplayAlerts = True
End With
wb.Save
my_files = Dir()
Loop
I am trying to save the file as .txt . I have error Run time error - automation error. Also there is a dialog asking me if I want to save data from a "page". How to turn this off?

Save new file excel with filename cell value

I need to generate many .xls files
renamed as the name contained in row A1, A2, A3 ....
example: NAME1.xls, NAME2.xls ...
and the new generated file must contain only the cells contained in the markers ####
(see IMG...cellD4:T32)
the markers change manually entered by me.
I tried this code only to save new .xls files
but it does not work....I do not know how to do the rest
Private Sub CommandButton1_Clickl()
Dim path As String
Dim filename1 As String
path = "C:\"
filename1 = Range("A1").Text
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=path & filename1 & ".xls", FileFormat:=x1OpenXMLWorkbook
Application.DisplayAlerts = True
ActiveWorkbook.Close
End Sub
Okay here ya go. This should grab the chunk of the original workbook you're looking for and save it as multiple new workbooks.
Option 1 removes formatting
Private Sub CommandButton1_Clickl()
Dim wksht As Worksheet
Set wksht = ActiveSheet
Dim path As String
path = "C:\test\"
If Len(Dir(path, vbDirectory)) = 0 Then
MkDir path
End If
Dim arr() As Variant
arr = wksht.Range("C3:U33").value
Dim wb As Workbook
Dim i As Long
For i = 1 To ActiveSheet.Range("A1").End(xlDown).Row
Set wb = Application.Workbooks.Add
wb.Sheets(1).Range("A1", Cells(UBound(arr), UBound(arr, 2))).value = arr
wb.SaveAs filename:=path & wksht.Range("A" & i).value & ".xlsx"
wb.Close
Next i
End Sub
Option 2 keeps formatting
Private Sub CommandButton1_Clickl()
Dim wksht As Worksheet
Set wksht = ActiveSheet
Dim path As String
path = "C:\test\"
If Len(Dir(path, vbDirectory)) = 0 Then
MkDir path
End If
Dim dataRange As Range
Set dataRange = wksht.Range("C3", wksht.UsedRange.SpecialCells(xlCellTypeLastCell))
Dim wb As Workbook
Dim i As Long
For i = 1 To wksht.Range("A" & wksht.rows.count).End(xlUp).Row
Set wb = Application.Workbooks.Add
dataRange.Copy wb.Sheets(1).Range("A1", wb.Sheets(1).Cells(dataRange.rows.count, dataRange.Columns.count))
wb.SaveAs filename:=path & wksht.Range("A" & i).value & ".xlsx"
wb.Close
Next i
End Sub
but note that the starting point is still C3 based on the example given.
Option 3 keeps formatting and selects the range between the 2 cells with #### in them
Private Sub CommandButton1_Clickl()
Dim wksht As Worksheet
Set wksht = ActiveSheet
Dim path As String
path = "C:\test\"
If Len(Dir(path, vbDirectory)) = 0 Then
MkDir path
End If
Dim rngeStart
Dim rngeEnd
Set rngeStart = wksht.UsedRange.Find(What:="####", LookIn:=xlValues, LookAt:=xlWhole)
Set rngeEnd = wksht.UsedRange.FindNext(After:=rngeStart)
Dim dataRange As Range
Set dataRange = wksht.Range(rngeStart, rngeEnd)
Dim wb As Workbook
Dim i As Long
For i = 1 To wksht.Range("A" & wksht.rows.count).End(xlUp).Row
Set wb = Application.Workbooks.Add
dataRange.Copy wb.Sheets(1).Range("A1", wb.Sheets(1).Cells(dataRange.rows.count, dataRange.Columns.count))
wb.SaveAs filename:=path & wksht.Range("A" & i).value & ".xlsx"
wb.Close
Next i
End Sub
Option 5 keeps row heights and column widths
Private Sub CommandButton1_Clickl()
Dim wksht As Worksheet
Set wksht = ActiveSheet
Dim path As String
path = "C:\test\"
If Len(Dir(path, vbDirectory)) = 0 Then
MkDir path
End If
Dim rngeStart
Dim rngeEnd
Set rngeStart = wksht.UsedRange.Find(What:="####", LookIn:=xlValues, LookAt:=xlWhole)
Set rngeEnd = wksht.UsedRange.FindNext(After:=rngeStart)
Dim dataRange As Range
Set dataRange = wksht.Range(rngeStart, rngeEnd)
Dim newDataRange As Range
Dim wb As Workbook
Dim i As Long
Dim j As Long
Dim k As Long
For i = 1 To wksht.Range("A" & wksht.Rows.Count).End(xlUp).Row
Set wb = Application.Workbooks.Add
Set newDataRange = wb.Sheets(1).Range("A1", wb.Sheets(1).Cells(dataRange.Rows.Count, dataRange.Columns.Count))
dataRange.Copy newDataRange
For j = 1 To dataRange.Columns.Count
newDataRange.Cells(1, j).ColumnWidth = dataRange.Cells(1, j).ColumnWidth
Next j
For k = 1 To dataRange.Rows.Count
newDataRange.Cells(k, 1).RowHeight = dataRange.Cells(k, 1).RowHeight
Next k
wb.SaveAs filename:=path & wksht.Range("A" & i).Value & ".xlsx"
wb.Close
Next i
End Sub
Try this:
Sub filename()
Dim i As Integer
For i = 1 To 32
ChDir "C:\path\"
ActiveWorkbook.SaveAs Filename:= _
"C:\path\" & Range("A" & i).Value & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Next i
End Sub
Note: Don't use "C:\" choose another folder. Probably you will need admin permissions to save there.

Resources