I am using the code below to copy a worksheet from a source workbook to several hundred destination workbooks. The source worksheet contains references (in formula) to other worksheets in the source workbook; I would like to keep these references between sheets, but in the destination workbook. Can this code be modified to do this?
Option Explicit
Public Sub CopySheetToAllWorkbooksInFolder()
Dim sourceSheet As Worksheet
Dim folder As String, filename As String
Dim destinationWorkbook As Workbook
'Worksheet in active workbook to be copied as a new sheet to the destination workbook
Set sourceSheet = ActiveWorkbook.Worksheets("Edit")
'Folder containing the destination workbooks
folder = "M:\Employee Information\Peter Young\Msc Project\1 - 181028 - Office First Floor\MacroCopy\"
filename = Dir(folder & "*.xlsx", vbNormal)
While Len(filename) <> 0
Debug.Print folder & filename
Set destinationWorkbook = Workbooks.Open(folder & filename)
sourceSheet.Copy before:=destinationWorkbook.Sheets(1)
destinationWorkbook.Close True
filename = Dir() ' Get next matching file
Wend
End Sub
Try something like this:
Public Sub CopySheetToAllWorkbooksInFolder()
Dim sourceWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim destinationWorkbook As Workbook
Dim folder As String, filename As String
'Worksheet in active workbook to be copied as a new sheet to the destination workbook
Set sourceWorkbook = ActiveWorkbook
Set sourceSheet = sourceWorkbook.Worksheets("Edit")
'Folder containing the destination workbooks
folder = "M:\Employee Information\Peter Young\Msc Project\1 - 181028 - Office First Floor\MacroCopy\"
filename = Dir(folder & "*.xlsx", vbNormal)
While Len(filename) <> 0
Debug.Print folder & filename
Set destinationWorkbook = Workbooks.Open(folder & filename)
sourceSheet.Copy before:=destinationWorkbook.Sheets(1)
destinationWorkbook.ChangeLink Name:=sourceWorkbook.Name, NewName:=destinationWorkbook.Name, Type:=xlExcelLinks
destinationWorkbook.Close True
filename = Dir() ' Get next matching file
Wend
End Sub
I got this by going to Data>Edit Links with the destination workbook active and the Macro Recorder turned on, choosing "Change Source" and then browsing to the destination workbook.
Related
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
This script loops through a file pathway and combines all workbooks into a master workbook and sections each workbook into a worksheet within the master file.
I have a line ws.Name = activeworksheet.Range("B1").Value that names the sheets as a copy of the first workbook's worksheet Sheet1 and names every sheet after that like Sheet1(2).
How can this be changed to the value in cell B1 of the workbook it is consolidating into the master workbook?
rest of script:
Option Explicit
Sub CombineWorkbooks()
Dim MainWB As Workbook
Dim sDirPath As String
Dim sFileName As String
Dim sFilePath As String
Dim wb As Workbook
Dim ws As Worksheet
sDirPath = "M:\New folder"
sFileName = Dir(sDirPath & "\*.xlsx")
Set MainWB = ThisWorkbook
Do While Len(sFileName) > 0
sFilePath = sDirPath & "\" & sFileName
Set wb = Workbooks.Open(Filename:=sFilePath)
For Each ws In wb.Sheets
ws.Copy After:=MainWB.Sheets(MainWB.Sheets.Count)
ws.Name = activeworksheet.Range("B1").Value
Next ws
wb.Close SaveChanges:=False
sFileName = Dir
Loop
End Sub
after .Copy() method of Sheet object, the newly created sheet becomes the active one, while ws still holds reference to the original sheet
so go like follows
For Each ws In wb.Sheets
ws.Copy After:=MainWB.Sheets(MainWB.Sheets.Count)
ActiveSheet.Name = ws.Range("B1").Value
Next
I am trying to split one excel file with multiple worksheets into separate file and then save them in separate folders based on a unique column.
So column A of each worksheet is labelled "AgencyName". There are about 80 agencies. I have 80 worksheets in one file for all these agencies.
Goal: To split these files using Column A as the file name and then save them in a folder that are named after each agency.
For example: of the agency is "Detroit". I have a worksheet for "Detroit" and a folder named exactly the same. I want to save this worksheet as a separate file under the Detroit Folder.
Any help will be highly appreciated.
For creating folders -- use filesystemobject (MORE HERE)
Example Script to create folder from MSDN...
Function CreateFolderDemo
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.CreateFolder("c:\New Folder")
CreateFolderDemo = f.Path
End Function
Now -- the other issue is creating a new workbook and adding any sheets to it that you need. See this answer on StackOverflow here! or you can read the MSDN on it here!
Example script might look like...
Dim newWorkBook As Workbook
Dim FileName As String
FileName = "C:\blabla\Detroit\Detroit.xls"
Set newWorkBook = Workbooks.Add(FileName)
Untested:
Sub Tester()
Const DEST As String = "C:\stuff\agencies\" 'adjust to suit...
Dim wbSrc As Workbook, sht As Worksheet, agency As String
Dim fldr As String
Set wbSrc = ActiveWorkbook
For Each sht In wbSrc.Worksheets
agency = sht.Range("A2").Value
sht.Copy
fldr = DEST & agency
If Dir(fldr, vbDirectory) <> "" Then
With ActiveWorkbook
.SaveAs fldr & "\data.xlsx"
.Close False
End With
Else
MsgBox "Sub-folder '" & fldr & "' not found!"
End If
Next sht
End Sub
The following macro will save each worksheet as the single worksheet in a new workbook:
Option Explicit
Public Sub SplitFile()
Const dstTopLevelPath As String = "C:\MyData\AgencyStuff"
Dim dstFolder As String
Dim dstFilename As String
Dim dstWB As Workbook
Dim dstWS As Worksheet
Dim srcWB As Workbook
Dim srcWS As Worksheet
Dim Agency As String
'Ensure the destination path exists
If Dir(dstTopLevelPath, vbDirectory) = "" Then
MsgBox dstTopLevelPath & " doesn't exist - please create it before running this macro"
End
End If
Set srcWB = ActiveWorkbook
For Each srcWS In srcWB.Worksheets
'Get the Agency name
'(use this line if the Agency name is in cell A2 of each worksheet)
Agency = srcWS.Range("A2").Value
'(use this line if the Agency name is the actual worksheet name)
'Agency = srcWS.Name
'Create the destination path
dstFolder = dstTopLevelPath & "\" & Agency
'Create the destination file name
'(use this line if you want the new workbooks to have a name equal to the agency name)
dstFilename = dstFolder & "\" & Agency & ".xlsx"
'(use this line if you want the new workbooks to have the same name as your existing workbook)
'(Note: If your existing workbook is called "xyz.xlsm", the new workbooks will have a ".xlsm"
' extension, even though there won't be any macros in them.)
'dstFilename = dstFolder & "\" & srcWB.Name
'(use this line if you want the new workbooks to have a fixed name)
'dstFilename = dstFolder & "\data.xlsx"
'Create a new workbook
Set dstWB = Workbooks.Add
'Copy the current sheet to the new workbook
srcWS.Copy Before:=dstWB.Sheets(1)
'Get rid of any sheets automatically created in the new workbook ("Sheet1", "Sheet2", etc)
For Each dstWS In dstWB.Worksheets
If dstWS.Name <> srcWS.Name Then
Application.DisplayAlerts = False
dstWS.Delete
Application.DisplayAlerts = True
End If
Next
'Ensure the new location exists, and create it if it doesn't
If Dir(dstFolder, vbDirectory) = "" Then
MkDir dstFolder
End If
'Save the new workbook to the required location
dstWB.SaveAs dstFilename
'Close the new workbook
dstWB.Close
Next
MsgBox "Finished"
End Sub
(This assumes that none of your source worksheets have names such as "Sheet1", "Sheet2", etc.)
I am using VBA to loop through a specified directory, open excel workbooks that exist in the directory, copy a range from a worksheet and paste the contents to a new workbook.
In the new workbook, I want to add a hyperlink to the workbook that was copied.
Here is the code I am using to open, copy, and paste.
How can I add a hyperlink to the "StrFile" in the last column of my new workbook?
code
Private Sub LoopThroughFiles()
Dim x As Workbook
Dim y As Workbook
' Create new workbook, name file, name sheets, set target directory
Set NewBook = Workbooks.Add
With NewBook
.SaveAs Filename:="C:\NewFileName" _
& Format(Date, "yyyymmdd") & ".xlsx"
NewBook.Sheets("Sheet1").Name = ("NewSheet")
End With
Dim dirName As String
' this is the directory to open files from
dirName = ("C:\TargetDirectory\")
Dim StrFile As String
StrFile = Dir(dirName & "*.*")
Do While Len(StrFile) > 0
If Right(StrFile, 4) = "xlsx" Then ' Filter for excel files
Workbooks.Open (dirName & StrFile) ' Open the workbook
Worksheets("TargetSheet").Range("A2:AA2").Copy ' Copy paste to new book
NewBook.Sheets("NewSheet").Columns("A").Find("", Cells(Rows.Count, "A")).PasteSpecial (xlPasteValuesAndNumberFormats)
Application.DisplayAlerts = False
Workbooks(StrFile).Close False ' Close target workbook without saving
Application.DisplayAlerts = True
End If
StrFile = Dir
Loop
End Sub
Something like this
I have used my code from Loop through files in a folder using VBA? to work with the xlsx files directly.
Also I have improved the use of variables to handle the workbooks you are working with
The code would also beenfit from error handling (ie if Target Sheet wasn't present etc)
Private Sub LoopThroughFiles()
Dim NewBook As Workbook
Dim WB As Workbook
Dim rng1 As Range
' Create new workbook, name file, name sheets, set target directory
Set NewBook = Workbooks.Add
With NewBook
.SaveAs Filename:="C:\temp\file" _
& Format(Date, "yyyymmdd") & ".xlsx"
.Sheets(1).Name = ("NewSheet")
End With
Dim dirName As String
' this is the directory to open files from
dirName = ("C:\temp\")
Dim StrFile As String
StrFile = Dir(dirName & "*.xlsx")
Application.DisplayAlerts = False
Do While Len(StrFile) > 0
Set WB = Workbooks.Open(dirName & StrFile) ' Open the workbook
WB.Worksheets("TargetSheet").Range("A2:AA2").Copy ' Copy paste to new book
Set rng1 = NewBook.Sheets("NewSheet").Columns("A").Find("", Cells(Rows.Count, "A"))
rng1.PasteSpecial xlPasteValuesAndNumberFormats
NewBook.Sheets(1).Hyperlinks.Add NewBook.Sheets(1).Cells(rng1.Row, "AB"), dirName & StrFile, dirName & StrFile
WB.Close False ' Close target workbook without saving
StrFile = Dir
Loop
Application.DisplayAlerts = True
End Sub
I have a sheet Rolling Plan in copy.xls worksheet.I want to copy it to Book1.xls worksheet in Sheet NO1 in Range A1:H6
The macro in Book.xls
Sub CopytoPS()
Dim sfil As String
Dim owbk As Workbook
Dim sPath As String
sPath = "C:\Users\Nirmala\Desktop\website" 'Change the file path for your purposes
sfil = Dir(sPath & "copy.xls")
Range("B6:H6").Copy
Set owbk = Workbooks.Open(sPath & sfil)
owbk.Sheets("RollinPlan").Range("B6:H6").End(xlUp).Offset(1, 0).
PasteSpecial xlPasteValues
owbk.Close True 'Save opened workbook and close
sfil = Dir
End Sub
This does the following:
1) Open copy.xls and copy data in range B6:H6
2) Pastes the data into workbook Book1 in range A1:H6 on sheet NO1
Sub CopyData()
Dim filePath As String, wb As Workbook
filePath = "C:\Users\Nirmala\Desktop\website" 'Change the file path for your purposes
Set wb = Workbooks.Open(Filename:=filePath & "\" & "copy.xls")
wb.Worksheets("Rolling Plan").Range("B6:H6").Copy Destination:=ThisWorkbook.Worksheets("NO1").Range("A1:H6")
wb.Close
End Sub
Note that I am not quite sure why the data range you are copying to (i.e. A1:H6) is much larger than the actual copied range (i.e. B6:H6).