I'm looking to do the following:
CommandButton in a destination Worksheet opens a source file (dialog box to choose which one)
Finds a worksheet (always the same name - "Performance") within the source file
Copies a range of cells (actually a couple of separate ranges - to be added)
Makes sure destination sheet (which has the same name as cell I2 in source sheet) exists
Pastes values to same ranges in destination Worksheet
Closes source file
I have this so far:
Private Sub CommandButton1_Click()
Dim SourceFile As String
Dim SourceBook As Workbook
Dim DestinationBook As Workbook
Dim desiredName As String
Set DestinationBook = ThisWorkbook
SourceFile = Application.GetOpenFilename(fileFilter:="Excel Macro-Enabled Workbook (*.xlsm), *.xlsm")
Set SourceBook = Workbooks.Open(SourceFile)
SourceBook.Sheets("Performance").Activate
desiredName = ActiveSheet.Range("I2")
Application.CutCopyMode = True
SourceBook.ActiveSheet.Range("E25:I64").Copy
DestinationBook.Activate
If WorksheetExists = False Then
MsgBox "Couldn't find " & desiredName & " sheet within destination workbook"
Call SourceBook.Close(False)
Exit Sub
Else
Range("E25:I64").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Call SourceBook.Close(False)
End If
End Sub
Function WorksheetExists() As Boolean
Dim sh As Object
For Each sh In DestinationBook.Worksheets
If sh.Name = desiredName Then WorksheetExists = True: sh.Activate
Exit For
Next
End Function
I'm getting Run-time error '424': Object Required
Any suggestions...?
Thanks in advance!
Here is a modification of your latest code. Notice these additions: 1) "Option Explicit" ensures you've properly declared all variables, 2) variables have been assigned to the important workbooks, worksheets, and ranges, 3) needed variables are passed to the WorkSheetExists function. For this to work there should be sheets named "Performance" and "testSheet" in the DestinationBook, and "testSheet" in I2 of the SourceBook. Remember, that this is just an attempt to "get you going" so I expect you'll need to modify.
Option Explicit
Sub test()
Dim SourceFile As String
Dim SourceBook As Workbook, performanceSh As Worksheet
Dim DestinationBook As Workbook
Dim desiredName As String
Set DestinationBook = ThisWorkbook
SourceFile = Application.GetOpenFilename(fileFilter:="Excel Macro-Enabled Workbook (*.xlsm), *.xlsm")
Set SourceBook = Workbooks.Open(SourceFile)
Set performanceSh = SourceBook.Sheets("Performance")
desiredName = performanceSh.Range("I2")
Application.CutCopyMode = True
performanceSh.Range("E25:I64").Copy
If WorksheetExists(DestinationBook, desiredName) = False Then
MsgBox "Couldn't find " & desiredName & " sheet within destination workbook"
SourceBook.Close(False)
Exit Sub
Else
Range("E25:I64").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
SourceBook.Close(False)
End If
End Sub
Function WorksheetExists(destWk As Workbook, theName As String) As Boolean
Dim sh As Object
For Each sh In destWk.Worksheets
If sh.Name = theName Then WorksheetExists = True: sh.Activate
Exit For
Next
End Function
Related
I have a workbook with many worksheets. I am attempting to use the below macro to cycle the worksheets, copy and paste value, then save off individually in a location.
I feel like I'm glossing over something very small and beginning to go bonkers. Currently this code copies and pastes value the first worksheet, and then saves the rest off without the copy/paste. So everything is working as desired with the exception of the copy/paste value not occurring with each worksheet.
Sub SaveFilesInFolder()
'
'This is for saving each worksheet as a workbook in a destination folder as an excel file
'
'
Dim sh As Worksheet
Dim wb As Workbook
For Each sh In Worksheets
With ActiveWorkbook
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
SheetName = sh.Name
sh.Copy
.SaveAs Filename:="C:\Location\" & SheetName
.Close SaveChanges:=True
End With
Next sh
End Sub
Any and all assistance is greatly appreciated.
Edit:
Below is the updated code from comments. Unfortunately, the sheet is still copying/pasting for the first worksheet and not the rest. Everything is saving in the specified location as intended.
Sub SaveFilesInFolder()
'
'This is for saving each worksheet as a workbook in a destination folder as an excel file
'
'
Dim sh As Worksheet
Dim wb As Workbook
Dim rng As Range
For Each sh In ThisWorkbook.Worksheets
Set rng = Cells
rng.Copy
rng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
sh.Copy
ActiveWorkbook.SaveAs ("C:\Location\" & sh.Name)
ActiveWorkbook.Close
Next sh
End Sub
Try it without the clipboard. I've also turned off alerts (for saving over files) and done a small amount of clean up.
Sub SaveFilesInFolder()
'
'This is for saving each worksheet as a workbook in a destination folder as an excel file
'
'
On Error GoTo e
Application.DisplayAlerts = False
Dim sh As Worksheet
For Each sh In ThisWorkbook.Worksheets
With sh.UsedRange
.Value2 = .Value2
End With
sh.Copy
ActiveWorkbook.Close True, "C:\Location\" & sh.Name
Next sh
e:
' Ensure alerts are turned back on before re-throwing.
Application.DisplayAlerts = True
If Err > 0 Then Err.Raise Err
End Sub
Export Worksheets
To leave the source workbook intact, convert formulas to values in the destination workbooks.
Sub ExportWorksheets()
Const dFolderPath As String = "C:\Location\"
Dim swb As Workbook: Set swb = ThisWorkbook
Dim dPath As String: dPath = dFolderPath
If Right(dPath, 1) <> Application.PathSeparator Then
dPath = dPath & Application.PathSeparator
End If
Application.ScreenUpdating = False
Dim sws As Worksheet
Dim dwb As Workbook
Dim dws As Worksheet
Dim drg As Range
For Each sws In swb.Worksheets
sws.Copy ' copied to a new single-worksheet workbook
Set dwb = Workbooks(Workbooks.Count) ' the last
Set dws = dwb.Worksheets(1) ' the one and only
Set drg = dws.UsedRange
drg.Value = drg.Value ' formulas to values
Application.DisplayAlerts = False ' to overwrite without confirmation
dwb.SaveAs dPath & dws.Name
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False ' it's already been saved
Next sws
Application.ScreenUpdating = True
MsgBox "Worksheets exported to single-worksheet workbooks.", vbInformation
End Sub
This error has been bugging me out for a while now and while running the macros individually, they always work. Since it was a bit of a work to run 10 macros individually, I decided to compile them into one module and can be run on a click of a form button. After doing that, I've been getting this error on the ActiveSheet.Paste for all of the macros. Any help would be appreciated. Thank you.
Sub ItemCode()
'
' AutoFilter Macro
' Scan itemCode
Dim WB As Workbook
Set WB = ActiveWorkbook
ActiveSheet.Range("C1").AutoFilter Field:=3, Criteria1:=Array("#DIV/0!", "#N/A", "#Ref", "Null"), Operator:=xlFilterValues
If Range("C1").End(xlDown).Value = "" Then
Call CustCode
Else
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Windows("SampleFile.xlsx").Activate
ActiveWorkbook.Sheets.Add.Name = "ItemCode"
Worksheets("ItemCode").Activate
ActiveSheet.Paste
Windows("ABF_Sample.xlsx").Activate
Application.CutCopyMode = False
Selection.AutoFilter
Application.StatusBar = "20% Completed"
End If
End Sub
Note: SampleFile.xlsx was declared in another macro.
Try this code. You will need to change the workbook and sheet names in the code to suit. It's always best to declare your workbooks and sheet names to avoid problems with pasting values in the wrong place. It also means you don't have to activate workbooks and worksheets which really slows down you code.
Sub ItemCode()
'
' AutoFilter Macro
' Scan itemCode
Dim WB1 As Workbook
Set WB1 = Workbooks("ABF_Sample")
Dim WS1 As Worksheet
Set WS1 = WB.Sheets("Sheet1")
Dim FilePath As String
Dim Filename As String
FilePath = "enter your file path here"
Filename = "SampleFile"
Dim WB2 As Workbook
Set WB2 = Workbooks.Add
ActiveWorkbook.SaveAs (FilePath & Filename & ".xlsx")
WS1.Range("C1").AutoFilter Field:=3, Criteria1:=Array("#DIV/0!", "#N/A", "#Ref", "Null"), Operator:=xlFilterValues
If WS.Range("C1").End(xlDown).Value = "" Then
Call CustCode
Else
WS1.UsedRange.Copy
With Workbooks(Filename)
.Sheets.Add.Name = "ItemCode"
.Sheets("ItemCode").Range("A1").PasteSpecial Paste:=xlPasteValues
End With
Application.CutCopyMode = False
Selection.AutoFilter
Application.StatusBar = "20% Completed"
End If
End Sub
I am trying to copy only data from one workbook into a new one, but with only four of the existing worksheets. The code below allows me to successfully copy all worksheets to a new workbook. This worked fine before, but now I only want to copy sheet 2-7, thus excluding sheet 1.
This is done by a user copying data into sheet 1 and the data will be populated to sheets 2-5. Sheet 6 & 7 contains metadata which will be the same for all new workbooks. To be able to import the copied data, I need a new workbook with sheets 2-7.
Sub Button1_Click()
Dim Output As Workbook
Dim Current As String
Dim FileName As String
Set Output = ThisWorkbook
Current = ThisWorkbook.FullName
Application.DisplayAlerts = False
Dim SH As Worksheet
For Each SH In Output.Worksheets
SH.UsedRange.Copy
SH.UsedRange.PasteSpecial xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Next
FileName = ThisWorkbook.Path & "\" & "Generic name.xlsx" 'Change name as needed
Output.SaveAs FileName, XlFileFormat.xlOpenXMLWorkbook
Workbooks.Open Current
Output.Close
Application.DisplayAlerts = True
End Sub
Any suggestions on how improve the code to only copy specified sheets, or to exclude sheet 1?
Copy a Set of Worksheets to Another Workbook
Option Explicit
Sub Button1_Click()
' Constants
Const dFileName As String = "Generic name.xlsx"
Dim DoNotCopy As Variant: DoNotCopy = Array(1) ' add more: Array(1, 7, 8)
Const ConversionWorksheetsCount As Long = 4
' Write the names of the desired worksheets to an array.
Dim swb As Workbook: Set swb = ThisWorkbook
Dim swsCount As Long: swsCount = swb.Worksheets.Count
Dim dwsNames() As String: ReDim dwsNames(1 To swsCount)
Dim sws As Worksheet
Dim sCount As Long
Dim dCount As Long
For Each sws In swb.Worksheets
sCount = sCount + 1
If IsError(Application.Match(sCount, DoNotCopy, 0)) Then
dCount = dCount + 1
dwsNames(dCount) = sws.Name
' Else ' worksheet index found in the 'DoNotCopy' array.
End If
Next sws
If dCount = 0 Then
MsgBox "No worksheets found.", vbCritical
Exit Sub
End If
If dCount < swsCount Then
ReDim Preserve dwsNames(1 To dCount)
End If
Application.ScreenUpdating = False
' Copy the desired worksheets to a new (destination) workbook.
swb.Worksheets(dwsNames).Copy
Dim dwb As Workbook: Set dwb = ActiveWorkbook
' Do the conversions.
Dim dws As Worksheet
Dim n As Long
For n = 1 To ConversionWorksheetsCount
On Error Resume Next
Set dws = dwb.Worksheets(n)
On Error GoTo 0
If Not dws Is Nothing Then ' destination worksheet exists
dws.Activate ' needed for '.Cells(1).Select'
With dws.UsedRange
.Copy
.PasteSpecial xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
.Cells(1).Select ' cosmetics
End With
Set dws = Nothing
'Else ' destination worksheet doesn't exist
End If
Next n
'dwb.Worksheets(1).Activate ' cosmetics
' Save the new (destination) workbook.
Dim dFilePath As String: dFilePath = swb.Path & "\" & dFileName
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs dFilePath, xlOpenXMLWorkbook
Application.DisplayAlerts = True
dwb.Close
' Note that you never modified the source. It's in the same state as before.
Application.ScreenUpdating = True
MsgBox "Workbook created.", vbInformation
End Sub
Add an If statement after the For Each loop to exclude Sheet1:
For Each SH In Output.Worksheets
If SH.Name <> "Sheet1" Then
SH.UsedRange.Copy
SH.UsedRange.PasteSpecial xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
End If
Next
I am modifying my current code to be more user friendly. My original code had hard coded file paths. The new code below is passing the file paths from a "control" sub where they are designated by an input box. The issue I am having is that now, once in the private sub routine, the If statements are no longer working. The only difference is that the file path is being passed from another sub instead of being hardcoded into this sub. I'm not sure what I am missing. Any help would be great.
Private Sub copyGLbuildings(NewRecPath As String, GLsrcPath As String)
Dim fname1 As Variant
Dim fname2 As Variant
Dim wb1 As Workbook
Dim Wb0 As Workbook
fname1 = Dir(GLsrcPath & "*Buildings*")
fname2 = Dir(NewRecPath & "*Buildings Rec*")
If fname1 <> "" Then
Set wb1 = Workbooks.Open(GLsrcPath & fname1)
End If
If fname2 <> "" Then
Set Wb0 = Workbooks.Open(NewRecPath & fname2)
End If
Wb0.Sheets(1).Name = "Data"
Wb0.Sheets.Add.Name = "GL"
wb1.Worksheets(1).UsedRange.Copy
Wb0.Worksheets("GL").UsedRange.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Wb0.Worksheets("GL").UsedRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Wb0.Worksheets("GL").UsedRange.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Wb0.Worksheets(1).Activate
ActiveWorkbook.Windows(1).DisplayGridlines = False
Call CleanFAGL
wb1.Close
Wb0.Close savechanges:=True
End Sub
The code looks fine to me. I would advise you put a break point right on the first If Statement and use View > Locals to check what the values of NewRecPath and GLsrcPath are being passed into the Sub Routine as.
Copy to Another Workbook
Using the Destination (written to) before the Source (read from) as the argument is quite unusual.
fname is better written like fName.
Neither of the fNames are ever going to be "", since you have previously added the patterns.
wb0 is a horrible idea, at least start numbering with 1 in the spirit of Excel and VBA. Note that my choice of variable names is also not quite good, but only you can improve it since you fully understand what it's all about.
If it's a worksheet then call it a worksheet (readability) or at least be consistent.
After adding a worksheet without arguments, it will 'land' before the selected (active) sheet, so if you only have one sheet in the workbook, it will be the first. If it isn't, why would you gamble with it, if you can settle this explicitly?
Have a think about the order of the PasteSpecial lines e.g. you adjusted the column widths before the data was copied.
Using sheet or worksheet indexes is prone to errors and confusion which in this case leads me to not knowing which worksheet should be 'deprived' of displaying grid lines.
The rest is covered in your comments.
Don't worry, we all were at this point at one time.
Carefully read the comments and modify the code appropriately.
Option Explicit
' Note that the arguments are switched due to the 'From To' logic.
Private Sub copyGLbuildings( _
ByVal SourcePath As String, _
ByVal DestinationPath As String)
' Validate
' Destination
Dim dwbName As String: dwbName = Dir(DestinationPath & "*Buildings Rec*")
If dwbName = "" Then Exit Sub
' Source
Dim swbName As String: swbName = Dir(SourcePath & "*Buildings*")
If swbName = "" Then Exit Sub
'Application.ScreenUpdating = False
' Destination
' Workbook
If Right(dwbName, 1) <> "\" Then
dwbName = dwbName & "\"
End If
Dim dwb As Workbook: Set dwb = Workbooks.Open(DestinationPath & dwbName)
' Worksheets
Dim dws1 As Worksheet: Set dws1 = dwb.Worksheets(1)
dws1.Name = "Data"
Dim dws2 As Worksheet
' Do it explicitly, even if there is previously only one worksheet.
Set dws2 = dwb.Worksheets.Add(After:=dws1) ' ??? maybe Before:=dws1
dws2.Name = "GL"
' Source
If Right(swbName, 1) <> "\" Then
swbName = swbName & "\"
End If
Dim swb As Workbook: Set swb = Workbooks.Open(SourcePath & swbName)
' Copy
swb.Worksheets(1).UsedRange.Copy
' Destination
' Paste
With dws2.UsedRange
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteColumnWidths
End With
Application.CutCopyMode = False
' Dispay Gridlines
dws1.Activate ' ??? if "Data" or dws2.Activate ' if "GL": depending on After
dwb1.Windows(1).DisplayGridlines = False
CleanFAGL ' ??? Not knowing what this does, doesn't help.
Application.DisplayAlerts = False
swb.Close SaveChanges:=False
dwb.Close SaveChanges:=True
Application.DisplayAlerts = True
'Application.ScreenUpdating = True
End Sub
Suppose I have a workbook1.xlsm with multiple worksheets and full of various formulas. I want to create a new workbook2.xlsx which would look exactly the same as workbook1 but in all the cells would be values instead of formulas.
I have this macro to copy one sheet from workbook1:
Sub nowe()
Dim Output As Workbook
Dim FileName As String
Set Output = Workbooks.Add
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Przestoje").Cells.Copy
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats
FileName = ThisWorkbook.Path & "\" & "worksheet2.xlsx"
Output.SaveAs FileName
End Sub
but the problem is it copies only one worksheet and does not name it like it was in worksheet1. I cannot figure it out.
Yet another problem is that worksheet2 is being opened afterwards. I do not want to do this.
How can I solve these problems?
I would do that as simply as possibly, without creating new workbook and copying sheets to it.
Few simple steps: taking into consideration thisworkbook >> for each worksheet within thisworkbook >> copy+paste values of used range within worksheet >> save as new workbook as xlsx type >> open back base workbook >> and finally close one we created.
The code will be simple and looks as follows:
Sub nowe_poprawione()
Dim Output As Workbook
Dim Current As String
Dim FileName As String
Set Output = ThisWorkbook
Current = ThisWorkbook.FullName
Application.DisplayAlerts = False
Dim SH As Worksheet
For Each SH In Output.Worksheets
SH.UsedRange.Copy
SH.UsedRange.PasteSpecial xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Next
FileName = ThisWorkbook.Path & "\" & "worksheet2.xlsx"
Output.SaveAs FileName, XlFileFormat.xlOpenXMLWorkbook
Workbooks.Open Current
Output.Close
Application.DisplayAlerts = True
End Sub
This should allow you to keep all the formatting, column widths, and only the values.
Option Explicit
Sub copyAll()
Dim Output As Workbook, Source As Workbook
Dim sh As Worksheet
Dim FileName As String
Dim firstCell
Application.ScreenUpdating = False
Set Source = ActiveWorkbook
Set Output = Workbooks.Add
Application.DisplayAlerts = False
Dim i As Integer
For Each sh In Source.Worksheets
Dim newSheet As Worksheet
' select all used cells in the source sheet:
sh.Activate
sh.UsedRange.Select
Application.CutCopyMode = False
Selection.Copy
' create new destination sheet:
Set newSheet = Output.Worksheets.Add(after:=Output.Worksheets(Output.Worksheets.Count))
newSheet.Name = sh.Name
' make sure the destination sheet is selected with the right cell:
newSheet.Activate
firstCell = sh.UsedRange.Cells(1, 1).Address
newSheet.Range(firstCell).Select
' paste the values:
Range(firstCell).PasteSpecial Paste:=xlPasteColumnWidths
Range(firstCell).PasteSpecial Paste:=xlPasteFormats
Range(firstCell).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Next
' delete the sheets that were originally there
While Output.Sheets.Count > Source.Worksheets.Count
Output.Sheets(1).Delete
Wend
FileName = ThisWorkbook.Path & "\" & "worksheet2.xlsx"
Output.SaveAs FileName
Output.Close
Application.ScreenUpdating = True
End Sub
Something like this would work to cycle through and copy all sheets after adding the workbook:
dim i as integer
For i = 1 To ThisWorkbook.Worksheets.Count
ThisWorkbook.Worksheets(i).Activate
ThisWorkbook.Worksheets(i).Select
Cells.Copy
Output.Activate
Dim newSheet As Worksheet
Set newSheet = Output.Worksheets.Add()
newSheet.Name = ThisWorkbook.Worksheets(i).Name
newSheet.Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Next
Note that this doesn't handle removing default sheets that automatically get created when the workbook gets created.
Also, worksheet2 is actually being opened (though not named til SaveAs) as soon as you call this:
Set Output = Workbooks.Add
Just close it after saving:
Output.Close
Something like this would work to cycle through and copy all sheets after adding the workbook - it builds on mr.Reband's answer, but with a few bells and whistles. Among other things it will work if this is in a third workbook (or an add-in etc), it deletes the default sheet or sheets that were created, it ensures the order of the sheets is the same as the original, etc:
Option Explicit
Sub copyAll()
Dim Output As Workbook, Source As Workbook
Dim sh As Worksheet
Dim FileName As String
Dim firstCell
Application.ScreenUpdating = False
Set Source = ActiveWorkbook
Set Output = Workbooks.Add
Application.DisplayAlerts = False
Dim i As Integer
For Each sh In Source.Worksheets
Dim newSheet As Worksheet
' select all used cells in the source sheet:
sh.Activate
sh.UsedRange.Select
Application.CutCopyMode = False
Selection.Copy
' create new destination sheet:
Set newSheet = Output.Worksheets.Add(after:=Output.Worksheets(Output.Worksheets.Count))
newSheet.Name = sh.Name
' make sure the destination sheet is selected with the right cell:
newSheet.Activate
firstCell = sh.UsedRange.Cells(1, 1).Address
newSheet.Range(firstCell).Select
' paste the values:
Range(firstCell).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Next
' delete the sheets that were originally there
While Output.Sheets.Count > Source.Worksheets.Count
Output.Sheets(1).Delete
Wend
FileName = ThisWorkbook.Path & "\" & "worksheet2.xlsx"
Output.SaveAs FileName
Output.Close
Application.ScreenUpdating = True
End Sub