I'm relatively new to VBA. I worked on the following code, which workED perfectly until I decided to filter for non-blanks before saving the sheet.
The idea is to save my sheet in the same path after filtering out any blank values. The new file will be values only in CSV. Again, all of that worked, except when it comes to filtering the data and saving the file.
Now I get the
"Run-time error 438 Object doesn’t support this property or method"
on the code below
ThisWorkbook.Sheets("SHEET1").SpecialCells(xlCellTypeVisible).Copy
The full code
Private Sub CommandButton1_Click()
If Sheets("SHEET1").AutoFilterMode Then Sheets("SHEET1").AutoFilterMode = False
sDate = Format(Sheets("SHEET2").Range("F1"), "YYYY.MM.DD")
cell = "NAME - " & sDate
ThisWorkbook.Sheets("SHEET1").Range("A:C").AutoFilter Field:=2, Criteria1:="<>"
ThisWorkbook.Sheets("SHEET1").SpecialCells(xlCellTypeVisible).Copy
With ActiveSheet.UsedRange
.Value = .Value
End With
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & cell & ".csv", FileFormat:=xlCSV
End Sub
Please read the code's comments and adjust it to fit your needs
EDIT: Adjusted a type in this row sourceSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(targetWorkbook.Sheets.Count).Range("A1")
Private Sub CommandButton1_Click()
Dim targetWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim formatDate As String
Dim fileName As String
Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")
' Remove filter
If sourceSheet.AutoFilterMode Then sourceSheet.AutoFilterMode = False
If sourceSheet.Range("F1").Value <> vbNullString Then
formatDate = Format(sourceSheet.Range("F1").Value, "YYYY.MM.DD")
End If
' Set the new workbook file name
fileName = "NAME - " & formatDate
' Filter the fileNames
sourceSheet.Range("A:C").AutoFilter Field:=2, Criteria1:="<>"
' Add new workbook and set reference
Set targetWorkbook = Workbooks.Add
' Copy the visible fileNames in a new workbook
sourceSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(targetWorkbook.Sheets.Count).Range("A1")
' Save the new workbook
targetWorkbook.SaveAs ThisWorkbook.Path & "\" & fileName & ".csv", FileFormat:=xlCSV
End Sub
Let me know if it works
Related
I have written VBA code in excel to copy a specific range on one tab and paste it to a new workbook which saves automatically.
However, the program I am inputting this file to is erroring because of one line that needs to be in text format. I am assuming I can just change the entire data set to text format and it would relieve my issues. The code is below. It has no other issues at the moment. I work at a public accounting firm so I have no idea what I am doing besides what I found on google.
Sub Reset()
Worksheets("Time Entry").Range("f11:j550").ClearContents
End Sub
Sub copypaste()
Set originalSheet = ActiveSheet
Set NewSheet = Sheets.Add(After:=ActiveSheet)
ActiveSheet.Name = Format(Date, "MM.DD.YY")
NewSheet.Range("a1:m490").Value = originalSheet.Range("q9:ac490").Value
ActiveSheet.Range("A:M").Columns.AutoFit
Dim lr As Integer
Dim i As Integer
lr = Cells(Rows.Count, 3).End(xlUp).Row
For i = lr To 6 Step -1
Debug.Print i
If IsError(Range("c" & i).Value) Then
Rows(i).EntireRow.Delete
End If
Next i
ActiveSheet.Move
Set NewWb = ActiveWorkbook
ActiveWorkbook.SaveAs Filename:=Environ("USERPROFILE") & "\Desktop\Time Tracker\" & NewFileName & Format(Date, "MM.DD.YY") & ".xlsx", FileFormat:=xlOpenXMLWorkbook
Exit Sub
ThisWorkbook.Close SaveChanges:=False
ErrorTrap:
MsgBox "Invalid directory. You must correct the path or save manually."
Resume Next
End Sub
i'm a beginner in VBA and i need to do the following. Starting from a workbook i should create another one without formulas and macro code.
I found some solutions and based on that i modeled my own code:
Sub SaveValuesOnly()
Dim wsCopy As Worksheet, wsPaste As Worksheet
Dim wb As Workbook
Dim sFileName As String, sPath As String
sPath = "C:\Users\"
sFileName = "OVERALL RECAP"
Set wsCopy = ThisWorkbook.Worksheets("INCIDENTS")
Set wb = Workbooks.Add
Set wsPaste = wb.Sheets(1)
wsCopy.Cells.copy
wsPaste.Cells.PasteSpecial xlPasteValues
wsPaste.Cells.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
wsPaste.Name = "Expenses" 'Change if needed
wb.SaveAs Filename:=sPath & sFileName, FileFormat:=xlOpenXMLWorkbook
End Sub
I need to copy more than one sheet and tried to use the official documentation like:
Worksheets(Array("Sheet1", "Sheet2", "Sheet4")).Copy
With ActiveWorkbook
.SaveAs Filename:=Environ("TEMP") & "\New3.xlsx", FileFormat:=xlOpenXMLWorkbook
.Close SaveChanges:=False
End With
But i didn't manage to implement this into the code above, any suggestion? Thanks.
Copy Worksheets to New Workbook
The Flow
Basically, the procedure will:
create a copy of ThisWorkbook (the workbook containing this code) in the destination folder,
open the copy and continue to work with it,
copy values to (remove formulas from) the specified worksheets,
delete the not specified sheets,
rename the specified worksheets,
save the copy to a new workbook in .xlsx format,
delete the copy.
Remarks
If a workbook with the same name (e.g. OVERALL RECAP) is already open, it will crash Excel.
Be careful when determining the worksheet names, because if you try to rename a worksheet using an already existing name, an error will occur.
The Code
Option Explicit
Sub copyWorksheets()
Const dPath As String = "C:\Users"
Const dFileName As String = "OVERALL RECAP"
Const CopyList As String = "INCIDENTS,Sheet2,Sheet3"
Const PasteList As String = "Expenses,Sheet2,Sheet4"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim CopyNames() As String: CopyNames = Split(CopyList, ",")
Dim PasteNames() As String: PasteNames = Split(PasteList, ",")
Dim nUpper As Long: nUpper = UBound(CopyNames)
Dim tFilePath As String: tFilePath = dPath & "\" & "t_" & wb.Name
Application.ScreenUpdating = False
' Save a copy.
wb.SaveCopyAs tFilePath
' Work with the copy.
With Workbooks.Open(tFilePath)
' Copy values (remove formulas).
Dim n As Long
For n = 0 To nUpper
With .Worksheets(CopyNames(n)).UsedRange
.Value = .Value
End With
Next n
' Delete other sheets.
Dim dCount As Long: dCount = .Sheets.Count - nUpper - 1
If dCount > 0 Then
Dim DeleteNames() As String: ReDim DeleteNames(1 To dCount)
Dim sh As Object ' There maybe e.g. charts.
n = 0
For Each sh In .Sheets
If IsError(Application.Match(sh.Name, CopyNames, 0)) Then
n = n + 1
DeleteNames(n) = sh.Name
End If
Next sh
Application.DisplayAlerts = False
.Sheets(DeleteNames).Delete
Application.DisplayAlerts = True
End If
' Rename worksheets.
For n = 0 To nUpper
If CopyNames(n) <> PasteNames(n) Then
.Worksheets(CopyNames(n)).Name = PasteNames(n)
End If
Next n
' Save workbook.
.Worksheets(1).Activate
Application.DisplayAlerts = False
.SaveAs _
Filename:=dPath & "\" & dFileName, _
FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
'.Close SaveChanges:=False ' Close the new workbook.
End With
' Delete the copy.
Kill tFilePath
Application.ScreenUpdating = True
MsgBox "Workbook created.", vbInformation, "Success"
'wb.Close SaveChanges:=False ' Close ThisWorkbook.
End Sub
The code below takes the opposite approach to the earlier one. It copies the entire workbook to a new name and then modifies it. You can list the sheets you want to keep. Formulas in them will be converted to their values. Sheets not listed will be deleted.
Sub SaveValuesOnly()
' 154
' list the sheets you want to keep by their tab names
Const SheetsToKeep As String = "Sheet1,Sheet3"
Dim sFileName As String
Dim sPath As String
Dim Wb As Workbook ' the new workbook
Dim Ws As Worksheet ' looping object: worksheet
Dim Keep() As String ' array of SheetsToKeep
Dim i As Long ' loop counter: Keep index
sPath = Environ("UserProfile") & "\Desktop\"
sFileName = "OVERALL RECAP"
Keep = Split(SheetsToKeep, ",")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
' create a copy of the ActiveWorkbook under a new name
ActiveWorkbook.SaveCopyAs sPath & sFileName & ".xlsm"
Set Wb = Workbooks.Open(sPath & sFileName & ".xlsm")
For Each Ws In Wb.Worksheets
' check if the sheet is to be kept
For i = UBound(Keep) To 0 Step -1
If StrComp(Ws.Name, Trim(Keep(i)), vbTextCompare) = 0 _
Then Exit For
Next i
If i = True Then ' True = -1
Ws.Delete
Else
' keep the sheet
With Ws.UsedRange
.Copy
.PasteSpecial xlPasteValuesAndNumberFormats
' you can repeat PasteSpecial here to copy more detail
End With
End If
Next Ws
' change the file format to xlsx (deleting copy of this code in it)
Wb.SaveAs Filename:=sPath & sFileName, FileFormat:=xlOpenXMLWorkbook
Kill sPath & sFileName & ".xlsm"
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
There are a few points you need to be aware of. One, the ActiveWorkbook will be copied. That is presumed to the ThisWorkbook (the one containing the code) but it could be any other. Two, any workbook by the targeted name already existing at the location specified by sPath will be over-written without warning. Three, alerts are turned off while the code runs. If it happens to crash they will remain turned off until you restart Excel or enter Application.DisplayAlerts = True [Enter] in the Immediate window.
Last, but not least, sheets are processed in sequence of their index numbers (left to right). If your formulas in the kept sheets refer to data in sheets that get deleted the sequence is important. You may have to run two loops instead of the one my code has. Use one loop to replace formulas and another just to delete.
I have the following code that produces a new worksheet. I'm trying to name the new worksheet using a Phrase, the content in Cell 1, and the date in Cell 2.
Cell 1 will contain some data that are inserted via Data Validation (4 options in total) and Cell 2 will have a date.
EXAMPLE:
Worksheet INPUTS Range C3. Cell 1 value = Trade Activities, Purchases, Sales...etc
Worksheet INPUTS Range C2. Cell 2 value = 2.11.2020
The new workbook's name will be "Client Name Trade Activities - 2.11.2020"
both Cell 1 and Cell 2 will be in the INPUTS worksheet
Private Sub CommandButton1_Click()
Dim targetWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim formatDate As String
Dim fileName As String
Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")
If sourceSheet.AutoFilterMode Then sourceSheet.AutoFilterMode = False
If ThisWorkbook.Worksheets("INPUTS").Range("C3").Value <> vbNullString Then
formatDate = Format(Sheets("INPUTS").Range("C3"), "YYYY.MM.DD")
End If
fileName = "Name - " & ActivityName & formatDate
sourceSheet.Outline.ShowLevels ColumnLevels:=1
sourceSheet.Range("A:M").AutoFilter Field:=12, Criteria1:="<>0"
Set targetWorkbook = Workbooks.Add
sourceSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(targetWorkbook.Sheets.Count).Range("A1")
targetWorkbook.Sheets("sheet1").Columns("A:AC").EntireColumn.AutoFit
targetWorkbook.SaveAs ThisWorkbook.Path & "\" & fileName & ".xlsx", FileFormat:=51
End Sub
Some things to remember:
Define and reuse your variables whenever you can
Try to add comments to your code, explaining the purpose of what you're doing (your future self or whom ever is going to work with your files, is going to thank you)
Leave spaces between your code's main parts, so it's more readable
EDIT: Added error handler, for when user clicks "No" when asking to overwrite existing file
Code:
Private Sub CommandButton1_Click()
Dim targetWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim formatDate As String
Dim fileName As String
On Error GoTo CleanFail
Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")
' Remove filter
If sourceSheet.AutoFilterMode Then sourceSheet.AutoFilterMode = False
If sourceSheet.Range("F1").Value <> vbNullString Then
formatDate = Format(sourceSheet.Range("F1").Value, "YYYY.MM.DD")
End If
' Set the new workbook file name
fileName = "NAME - " & formatDate
' Filter the fileNames
sourceSheet.Range("A:C").AutoFilter Field:=2, Criteria1:="<>"
' Add new workbook and set reference
Set targetWorkbook = Workbooks.Add
' Copy the visible fileNames in a new workbook
sourceSheet.UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(targetWorkbook.Sheets.Count).Range("A1")
' Save the new workbook
targetWorkbook.SaveAs ThisWorkbook.Path & "\" & fileName & ".csv", FileFormat:=xlCSV
CleanExit:
Exit Sub
CleanFail:
Select Case Err.Number
Case 1004
MsgBox "You cancel the process"
Resume Next
Case Else
' Do something else? handle it properly...
MsgBox "Something went wrong..."
Resume CleanExit
End Select
End Sub
Let me know if it works
My current vba code copies data from one sheet of my current and creates a new workbook with the data from that sheet.
Sub copying_data()
Dim FilePath As String: FilePath = ThisWorkbook.Path & "\"
Dim FName As String
FName = FilePath & "Summary_Output_" & _
Format(Date, "ddmmmyyyy") & ".xlsx"
ThisWorkbook.Sheets("AA_New").Copy
ActiveWindow.DisplayGridlines = False
ActiveWindow.Zoom = 110
ActiveWindow.Zoom = 120
Set NewBook = ActiveWorkbook
NewBook.SaveAs Filename:=FName
End Sub
This is currently working fine, but when it pastes the data it links it to the old sheet, instead I want it to paste the data as value but keeping the same formatting, is there any way to do this?
Add the file first then copy and paste special the values and formatting into the new sheet:
Sub copying_data()
Dim FilePath As String
FilePath = ThisWorkbook.Path & "\"
Dim FName As String
FName = FilePath & "Summary_Output_" & _
Format(Date, "ddmmmyyyy") & ".xlsx"
Dim swb As Workbook
Set swb = ThisWorkbook
Dim twb As Workbook
Set twb = Workbooks.Add
swb.Worksheets("AA_New").UsedRange.Copy
With twb.Worksheets(1).Range("A1")
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
twb.Worksheets(1).Name = "AA_New"
twb.SaveAs Filename:=FName
End Sub
Just small variations to Scott's answer which is perfectly valid.
Variable names conventions
Defining the file name in a different variable to use it in other steps
Windows adjustments you had in your code
Public Sub copying_data()
Dim newBook As Workbook
Dim filePath As String
Dim fileName As String
Dim fileFullPath As String
' Build the path
filePath = ThisWorkbook.Path & "\"
fileName = "Summary_Output_" & _
Format(Date, "ddmmmyyyy") & ".xlsx"
fileFullPath = filePath & fileName
' Add a new workbook
Set newBook = Workbooks.Add
' Save it with the path built
newBook.SaveAs fileFullPath
' Copy the sheet
ThisWorkbook.Sheets("AA_New").Copy Before:=Workbooks(fileName).Sheets(1)
' Copy/paste values
newBook.Sheets("AA_New").UsedRange.Copy
newBook.Sheets("AA_New").UsedRange.PasteSpecial xlPasteValues
newBook.Sheets("AA_New").UsedRange.PasteSpecial xlPasteFormats
' Adjust the window
Windows(fileName).DisplayGridlines = False
Windows(fileName).Zoom = 110
Windows(fileName).Zoom = 120
End Sub
I want to ask one question.
I wrote a simple code where I click a Save button and then save as the excel file in "C:\new folder\". The problem I have now is how to save the last row of the original excel sheet in "C:\new folder\" if I add new row in original excel sheet.
I want the sheet which will be saved to contain only one row, from original excel sheet.
Sub Increment()
Range("A1").Value = Range("A1").Value + 1
End Sub
Private Sub CommandButton1_Click()
Dim Path As String
Dim FileNane1 As String
Dim FileName2 As String
Path = "C:\new folder\"
Call Increment
FileNane1 = Range("A1").Value
FileName2 = Range("B1")
ActiveWorkbook.SaveAs Filename:=Path & FileNane1 & "-" & FileName2 & ".xls"
End Sub
The above saves the entire excel sheet in "C:\new folder\" where I need only last row.
How can I solve this?
Although it sounds like Greg's code may work for you (assuming that you figured out why the file was not saving correctly) it is more efficient to avoid using the .Select method except when absolutely necessary.
You were very close to functional with your original code, and could do what you want by adding just four lines to your original code:
Private Sub CommandButton1_Click()
Dim Path As String
Dim FileName1 As String
Dim FileName2 As String
Path = "C:\new folder\"
Call Increment
FileName1 = Range("A1").Value
FileName2 = Range("B1")
'~~>find and copy the last row
Range("A" & ActiveSheet.Rows.Count).End(xlUp).EntireRow.Copy
'~~>add a new workbook and paste the content before saving
Workbooks.Add
ActiveWorkbook.ActiveSheet.PasteSpecial
ActiveWorkbook.SaveAs filename:=Path & FileName1 & "-" & FileName2 & ".xls"
'~~>close the new workbook
ActiveWorkbook.Close (False)
End Sub
I'm a little confused on exactly what you want to do, but this should get you pretty close (assuming I understand correctly). This will select the last row of text, assuming there are no empty cells in Column A between A1 and the last row.
Sub SaveLastLine()
'Variable declaration
Dim WB As Workbook, _
filename As String
'Turn off screen updating and alerts
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Make a copy of the last line of active sheet
newName = ActiveSheet.Name
Range("A1").Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select
Set WB = ActiveWorkbook
filename = newName & ".xlsx"
WB.SaveAs filename:="C:\New Folder\" & filename, FileFormat:=51
'Restore screen updating and alerts
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub