When i use this code i get save as window and save workbook as i whish, but i also get one more workbook with active sheet from original, need help to get just one and if it is possible to close it after saving.
Code
Sub WorksheetSaveToNewWorkbook()
Dim loc As Variant
Dim Rng As Range
Dim newName As String
Dim newWkb As Workbook
Dim newWks As Worksheet
Dim Wks As Worksheet
Dim Shp As Shape
Application.DisplayAlerts = False
Set Wks = ThisWorkbook.ActiveSheet
Set Rng = Wks.Range("Q3:S170")
Data = Range("Q3:S170")
Wks.Copy
Set newWkb = Workbooks.Add
Set newWks = newWkb.ActiveSheet
With newWks
.Range("A1").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
newName = " inklinometrija" & ".xlsx"
For Each Shp In .Shapes
Shp.OnAction = ""
Next Shp
loc = Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Save As...", InitialFileName:=newName)
If loc <> False Then
ActiveWorkbook.SaveAs Filename:=loc, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
Exit Sub
End If
Application.DisplayAlerts = True
End With
End Sub
Wks.Copy
Set newWkb = Workbooks.Add
Set newWks = newWkb.ActiveSheet
Wks.copy is in fact the code to create a new workbook with just that worksheet.
Related
Hi I have the following code which loops through dropdown selections and saves each result as a new workbook based on the named range in cell G3. I am trying to edit the code so that it saves all the worksheets to the new file instead of just the active one, if anyone could help? thank you
Sub myFiles()
Dim wb As Workbook
Dim ws As Worksheet
Dim nwb As Workbook
Dim nws As Worksheet
Dim rng As Range
Dim Path As String
Dim myDate As String
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Summary")
Set rng = ws.Range("G3")
Path = "C:\Users\bradley\Desktop\Sales by Month\"
myDate = Format(Now(), "MM-DD-YYYY")
For i = 1 To 4
rng = ws.Range("J" & i)
ws.Copy
Set nwb = ActiveWorkbook
Set nws = nwb.Worksheets("Summary")
With nws
Cells.Copy
Cells.PasteSpecial (xlPasteValues)
End With
Application.DisplayAlerts = False
nwb.SaveAs FileName:=Path & rng & " " & myDate & ".xlsx",
FileFormat:=xlWorkbookDefault
nwb.Close
Application.DisplayAlerts = True
Next i
End Sub
Loop through the sheets but only create a workbook on the first one.
Option Explicit
Sub myFiles()
Const FOLDER = "C:\Users\bradley\Desktop\Sales by Month\"
Dim wb As Workbook, nwb As Workbook
Dim ws As Worksheet, rng As Range
Dim myDate As String, i As Long, j As Long
Dim filename As String
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Summary")
Set rng = ws.Range("G3")
myDate = Format(Now(), "MM-DD-YYYY")
Application.ScreenUpdating = False
For i = 1 To 4
rng.Value2 = ws.Range("J" & i).Value2
' copy all sheets
For j = 1 To wb.Sheets.Count
If j = 1 Then
wb.Sheets(j).Copy
Set nwb = ActiveWorkbook
Else
wb.Sheets(j).Copy after:=nwb.Sheets(j - 1)
End If
With nwb.Sheets(j)
.UsedRange.Value2 = .UsedRange.Value2
End With
Next
' save workbook
filename = FOLDER & rng.Value2 & " " & myDate & ".xlsx"
Application.DisplayAlerts = False
nwb.SaveAs filename:=filename, FileFormat:=xlWorkbookDefault
nwb.Close
Application.DisplayAlerts = True
Next i
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
I need to combine multiple workbook to one workbook.
Source workbooks have unique sheet name = "job"
Destination workbook have multiple sheets name
The Below code have 2 issues,
For loop not work
pasted data in Destination workbook create a new sheet. But i need to paste the data to existing sheet.
Sub combine()
'destination worksheets
Dim Ar As Worksheet
Dim nr As Worksheet
Set Ar = ThisWorkbook.Sheets("sheetAr")
Set nr = ThisWorkbook.Sheets("Sheetnr")
'Source workbooks
Dim FolderPath As String
Dim Filename As String
Application.ScreenUpdating = False
FolderPath = Environ("userprofile" & "\Desktop\Copy")
Filename = Dir(FolderPath & "*.xlsx*")
Do While Filename <> ""
Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
Dim ws As Worksheet
Dim AW As Workbook
Set AW = ActiveWorkbook
Set ws= ActiveWorkbook.Sheets("Job")
For Each AW In ws
AW.Activate
Cells.ShownAll
ws.Copy Ar
Next AW
Workbooks(Filename).Close savechanges = True
Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub
FolderPath = Environ("userprofile" & "\Desktop\Copy") should be FolderPath = Environ("userprofile") & "\Desktop\Copy\".For Each AW In ws makes no sense since AW is a workbook and ws a worksheet. You probably meant For Each ws in AW but there is no need to loop if only Job sheet is the source. Workbooks(Filename).Close savechanges = True is missing : but since the workbook was opened read-only there are no change to save so use .Close savechanges := False.
Option Explicit
Sub combine()
Dim wb As Workbook, rng As Range
Dim wsAr As Worksheet, wsSrc As Worksheet
Dim FolderPath As String, Filename As String
Dim iTargetRow As Long, c As Long, n As Long
FolderPath = Environ("userprofile") & "\Desktop\Copy\"
Filename = Dir(FolderPath & "*.xlsx*")
' destination worksheet
Set wsAr = ThisWorkbook.Sheets("sheetAr")
iTargetRow = wsAr.UsedRange.Row + wsAr.UsedRange.Rows.Count
Application.ScreenUpdating = False
Do While Filename <> ""
Set wb = Workbooks.Open(Filename:=FolderPath & Filename, ReadOnly:=True)
Set wsSrc = wb.Sheets("Job")
Set rng = wsSrc.UsedRange
rng.Copy wsAr.Cells(iTargetRow, rng.Column)
iTargetRow = iTargetRow + rng.Rows.Count
wb.Close savechanges:=False ' opened read only
Filename = Dir()
n = n + 1
Loop
Application.ScreenUpdating = True
MsgBox n & " workbooks scanned", vbInformation
End Sub
I'm trying to loop through files in a folder with following path "C:\Users\Ouen\Downloads\Test" and paste each output into a new specific sheet in a MASTER workbook.
For example, the below are all the same worksbooks that each have a specific worksheet called "Annual" with different outputs:
Asset1
Asset2
Asset3
Etc
I would like to copy the whole Annual worksheet from each of the workbooks above and paste into a MASTER workbook, while being able to rename them to the following:
Asset1 - Annual
Asset2 - Annual
Asset3 - Annual
Etc
I have had some luck in copying and pasting from each workbook into the master but I'm unable to to paste each output into a new worksheet within the master and rename. Any ideas?
Sub Assets2Master()
Dim xRg As Range
Dim xSelItem As Variant
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook As Workbook
Dim xSheet As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "Annual"
xRgStr = "B1:GI100"
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
With xFileDlg
If .Show = -1 Then
xSelItem = .SelectedItems.Item(1)
Set xWorkBook = ThisWorkbook
Set xSheet = xWorkBook.Sheets("MASTER")
If xSheet Is Nothing Then
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count)).Name = "MASTER"
Set xSheet = xWorkBook.Sheets("MASTER")
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
If xFileName = "" Then Exit Sub
Do Until xFileName = ""
Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFileName = Dir()
xBook.Close
Loop
End If
End With
et xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = True
xRg.UseStandardWidth = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Copy to the end
This code will copy, if it exists, the Annual worksheet from each workbook in the folder you select via the dialog.
They will be copied to the workbook the code is in and the copied sheets will be renamed with the name of the workbook they came from appended with - Annual.
The copied sheets will be copied after the last sheet in the MASTER workbook.
Sub Assets2Master()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim dlg As Object
Dim strFileName As String
Dim strFolder As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
With dlg
If .Show = -1 Then
strFolder = .SelectedItems.Item(1)
End If
End With
Set wbDst = ThisWorkbook
strFileName = Dir(strFolder & "\*.xlsx", vbNormal)
If strFileName = "" Then Exit Sub
Do Until strFileName = ""
If strFileName <> wbDst.Name Then
Set wbSrc = Workbooks.Open(strFolder & "\" & strFileName)
' check if 'Annual' sheet exists, and if it does copy it to master workbook
If IfSheetExists("Annual", wbSrc) Then
Set wsSrc = wbSrc.Sheets("Annual")
With wbDst
wsSrc.Copy After:=.Sheets(.Sheets.Count)
.Sheets(.Sheets.Count).Name = Left(strFileName, Len(strFileName) - 5) & " - Annual"
End With
End If
wbSrc.Close SaveChanges:=False
End If
strFileName = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Function IfSheetExists(strName As String, Optional wb As Workbook) As Boolean
' checks for the existence of a worksheet named strName in the, optional, workbook wb
' if wb not stated checks in the active workbook
Dim ws As Worksheet
If wb Is Nothing Then
Set wb = ActiveWorkbook
End If
For Each ws In wb.Sheets
If ws.Name = strName Then
IfSheetExists = True
Exit For
End If
Next ws
End Function
Copy after specific sheet
This code is basically identical to the previous code but the workheets will be copied after a specific worksheet in the MASTER workbook.
Option Explicit
Sub Assets2Master()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim dlg As Object
Dim strFileName As String
Dim strFolder As String
Dim lngDstIndex As Long
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
With dlg
If .Show = -1 Then
strFolder = .SelectedItems.Item(1)
End If
End With
Set wbDst = ThisWorkbook
' change Specific Tab to the name ypu want the sheets to be copied after
lngDstIndex = wbDst.Sheets("Specific Tab").Index
strFileName = Dir(strFolder & "\*.xlsx", vbNormal)
If strFileName = "" Then Exit Sub
Do Until strFileName = ""
If strFileName <> wbDst.Name Then
Set wbSrc = Workbooks.Open(strFolder & "\" & strFileName)
' check if 'Annual' sheet exists, and if it does copy it to master workbook
If IfSheetExists("Annual", wbSrc) Then
Set wsSrc = wbSrc.Sheets("Annual")
With wbDst
' copy sheet to MASTER workbook
wsSrc.Copy After:=.Sheets(.Sheets.Count)
' rename sheet and move it after specified sheet
With .Sheets(.Sheets.Count)
.Name = Left(strFileName, Len(strFileName) - 5) & " - Annual"
.Move After:=wbDst.Sheets(lngDstIndex)
lngDstIndex = lngDstIndex + 1
End With
End With
End If
wbSrc.Close SaveChanges:=False
End If
strFileName = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Function IfSheetExists(strName As String, Optional wb As Workbook) As Boolean
' checks for the existence of a worksheet named strName in the, optional, workbook wb
' if wb not stated checks in the active workbook
Dim ws As Worksheet
If wb Is Nothing Then
Set wb = ActiveWorkbook
End If
For Each ws In wb.Sheets
If ws.Name = strName Then
IfSheetExists = True
Exit For
End If
Next ws
End Function
Try this. The Master wb should be placed in a different folder than the one you store the Asset Files:
Sub Assets2Master()
Dim xRg As Range
Dim xSelItem As Variant
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook As Workbook
Dim xSheet As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "Annual"
xRgStr = "B1:GI100"
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
With xFileDlg
If .Show = -1 Then
xSelItem = .SelectedItems.item(1)
Set xWorkBook = ActiveWorkbook
Set xSheet = xWorkBook.Sheets("MASTER")
If xSheet Is Nothing Then
xWorkBook.Sheets.Add(After:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "MASTER"
Set xSheet = xWorkBook.Sheets("MASTER")
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
If xFileName = "" Then Exit Sub
Do Until xFileName = ""
Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFileName = Dir()
xBook.Close
xBook.Name = xBook.Name & " - Annual"
Loop
End If
End With
Set xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = True
xRg.UseStandardWidth = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Stack Ranges
This is about what I thought your code was supposed to do. What you asked for is kind of illustrated with the commented block of code in the Do...Loop. By modifying the code in the Do...Loop, there are many possibilities of what you could achieve.
Option Explicit
Sub StackRanges()
' Source
Const sName As String = "Sheet1" ' "Annual"
Const sAddress As String = "B1:GI100"
' Destination
Const dName As String = "MASTER"
Const dCol As String = "A"
Application.ScreenUpdating = False
' Open the dialog to pick a folder.
Dim xFileDlg As FileDialog
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Dim sFolderPath As Variant
With xFileDlg
.InitialFileName = ThisWorkbook.Path
If .Show = True Then
sFolderPath = .SelectedItems.Item(1)
Else
MsgBox "Canceled.", vbExclamation, "Assets2Master"
Exit Sub
End If
End With
' Write the name of the first file to the Source File Name variable.
Dim sfName As String: sfName = Dir(sFolderPath & "\*.xlsx")
' Validate first Source File Name.
If Len(sfName) = 0 Then Exit Sub ' no files found
' Create a reference to the Destination Workbook.
Dim dwb As Workbook: Set dwb = ThisWorkbook
' Write the name of the Destination Workbook
' to the Destination File Name variable.
Dim dfName As String: dfName = dwb.Name
' Attempt to create a reference to the Destination Worksheet.
Dim dws As Worksheet
On Error Resume Next
Set dws = dwb.Worksheets(dName)
On Error GoTo 0
' If the attempt was unsuccessful, add a new worksheet and do it now.
If dws Is Nothing Then
dwb.Worksheets.Add(After:=dwb.Sheets(dwb.Sheets.Count)).Name = dName
Set dws = dwb.Worksheets(dName)
' Maybe add some headers... to the Destination Worksheet.
End If
' Create a reference to the (first) Destination Range.
Dim drg As Range: Set drg = dws.Range(sAddress)
Dim rCount As Long: rCount = drg.Rows.Count
Dim cCount As Long: cCount = drg.Columns.Count
Set drg = dws.Cells(dws.Rows.Count, dCol).End(xlUp) _
.Offset(1, 0).Resize(rCount, cCount)
' Declare additional variables for the following 'Do Loop'.
Dim swb As Workbook
Dim sws As Worksheet
Dim srg As Range
' Loop through the files in the folder...
Do Until Len(sfName) = 0
' Check if the Source File Name is different
' than the Destination File Name.
If StrComp(sfName, dfName, vbTextCompare) <> 0 Then
' Open and create a reference to the Source Workbook.
Set swb = Workbooks.Open(sFolderPath & "\" & sfName)
' Attempt to create a reference to the Source Worksheet.
Set sws = Nothing
On Error Resume Next
Set sws = swb.Worksheets(sName)
On Error GoTo 0
' Stack Ranges
' If the attempt was successful...
If Not sws Is Nothing Then
' Create a reference to the Source Range.
Set srg = sws.Range(sAddress)
' Copy the values from the Source to the Destination Range
' by assignment.
drg.Value = srg.Value
' Create a reference to the (next) Destination Range.
Set drg = drg.Offset(rCount)
End If
' ' Copy Worksheets (instead)
'
' ' If the attempt was successful...
' If Not sws Is Nothing Then
' sws.Copy After:=dwb.Sheets(dwb.Sheets.Count)
' ' Caution: Has to be less than 32 characters!
' ActiveSheet.Name = Left(sfName, Len(sfName) - 5) & " - " & sName
' End If
' Close the Source Workbook.
swb.Close SaveChanges:=False
End If
' Write the name of the next file to the Source File Name variable.
sfName = Dir
Loop
Application.ScreenUpdating = True
' Inform the user.
MsgBox "Data copied.", vbInformation, "Assets2Master"
End Sub
so I have about 21 sheets that are all named the exact same across about 16 files. All the formats and such are the exact same, so for example I need to combine all the sheets with "Age" in all 16 files into a master file that will have the "Age" sheet with the aggregated data of all 16 "Age" sheets. Similarly for the other 20 sheet types.
I'm not sure how exactly to do this. I have a macro that currently adds all sheets in a file together into one master workbook, and I'm looking to modify this so it combines similar sheets instead of just adding them all into one workbook.
Any ideas would be appreciated!
Sub AddAllWS()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = "C:\Documents and Settings\path\to"
Set wbDst = ThisWorkbook
strFilename = Dir(MyPath & "\*.xls", vbNormal)
If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Set wsSrc = wbSrc.Worksheets(1)
wsSrc.UsedRange.Copy
wsSrc.Paste (wbSrc.Range("A" & Rows.Count).End(xlUp).Offset(1))
wbSrc.Close False
strFilename = Dir()
Loop
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
You seem to be copying and pasting into the same source worksheet. Check the code below. That might work. I put in comments in the code.
Sub AddAllWS()
Dim wbDst As Workbook
Dim wsDst As Worksheet
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Dim lLastRow As Long
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Set wbDst = ThisWorkbook
MyPath = "C:\Documents and Settings\path\to\"
strFilename = Dir(MyPath & "*.xls*", vbNormal)
Do While strFilename <> ""
Set wbSrc = Workbooks.Open(MyPath & strFilename)
'loop through each worksheet in the source file
For Each wsSrc In wbSrc.Worksheets
'Find the corresponding worksheet in the destination with the same name as the source
On Error Resume Next
Set wsDst = wbDst.Worksheets(wsSrc.Name)
On Error GoTo 0
If wsDst.Name = wsSrc.Name Then
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
wsSrc.UsedRange.Copy
wsDst.Range("A" & lLastRow).PasteSpecial xlPasteValues
End If
Next wsSrc
wbSrc.Close False
strFilename = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I have the code to copy all the sheets from one excel file to another, but I only have one sheet and when it copies it paste the original as sheet1 (2) in to the destination file.
I need the code to not create a new sheet just past sheet1 into sheet1 of the destination file
I tryed playing with it but could not get it
Thanks
Sub CopySheets()
Dim WB As Workbook
Dim SourceWB As Workbook
Dim WS As Worksheet
Dim ASheet As Worksheet
'Turns off screenupdating and events:
Application.ScreenUpdating = False
Application.EnableEvents = False
'Sets the variables:
Set WB = ActiveWorkbook
Set ASheet = ActiveSheet
Set SourceWB = Workbooks.Open(WB.Path & "\MyOtherWorkbook.xls") 'Modify to match
'Copies each sheet of the SourceWB to the end of original wb:
For Each WS In SourceWB.Worksheets
WS.Copy after:=WB.Sheets(WB.Sheets.Count)
Next WS
SourceWB.Close savechanges:=False
Set WS = Nothing
Set SourceWB = Nothing
WB.Activate
ASheet.Select
Set ASheet = Nothing
Set WB = Nothing
Application.EnableEvents = True
End Sub
Try below code.The below code can fail if the source workbook is in excel 2010 (xlsx) and destination workbook is in excel 2003 (xls). You may also have a look at RDBMerge Addin.
Sub CopySheets()
Dim SourceWB As Workbook, DestinWB As Workbook
Dim SourceST As Worksheet
Dim filePath As String
'Turns off screenupdating and events:
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'path refers to your LimeSurvey workbook
Set SourceWB = Workbooks.Open(ThisWorkbook.Path & "\LimeSurvey.xls")
'set source sheet
Set SourceST = SourceWB.Sheets("Management Suite Feedback - Tri")
SourceST.Copy
Set DestinWB = ActiveWorkbook
filePath = CreateFolder
DestinWB.SaveAs filePath
DestinWB.Close
Set DestinWB = Nothing
Set SourceST = Nothing
SourceWB.Close
Set SourceWB = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function CreateFolder() As String
Dim fso As Object, MyFolder As String
Set fso = CreateObject("Scripting.FileSystemObject")
MyFolder = ThisWorkbook.Path & "\Reports"
If fso.FolderExists(MyFolder) = False Then
fso.CreateFolder (MyFolder)
End If
MyFolder = MyFolder & "\" & Format(Now(), "MMM_YYYY")
If fso.FolderExists(MyFolder) = False Then
fso.CreateFolder (MyFolder)
End If
CreateFolder = MyFolder & "\Data " & Format(Now(), "DD-MM-YY hh.mm.ss") & ".xls"
Set fso = Nothing
End Function