I have the following code designed to copy a worksheet to a new location.
Sub XLSSave()
Sheets("Group Import").Copy
Cells.Copy
Cells.PasteSpecial xlPasteValues
ActiveWorkbook.SaveAs Filename:=Sheets("Group Import").Range("B22")
ActiveWorkbook.Close False
End Sub
Cell K67 is a file Path along the lines of
"C\Folder1\Folder2\Folder3\YYYY\MM\DD"
"C:\Folder1\Folder2\Folder3\YYYY\MM\DD".
The path "C:" was set correctly, I made a typo on the question.
I had intended to just concatenate the address within cell B22 as it needs to be dynamic.
It is exporting the Excel file as gibberish.
Export Worksheet
Easy
Option Explicit
Sub XLSSaveEasy()
Application.ScreenUpdating = False
Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets("Group Import")
sws.Copy
Dim dws As Worksheet: Set dws = ActiveWorkbook.Worksheets(1)
dws.UsedRange.Value = dws.UsedRange.Value
Application.DisplayAlerts = False
dws.Parent.SaveAs sws.Range("B22").Value, xlOpenXMLWorkbook
Application.DisplayAlerts = True
dws.Parent.Close False
Application.ScreenUpdating = True
End Sub
Not So Easy
Sub XLSSave()
Const swsName As String = "Group Import"
Const swsFilePathCell As String = "B22"
Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets(swsName)
Dim FilePath As String: FilePath = sws.Range(swsFilePathCell).Value
Dim FolderPath As String
FolderPath = Left(FilePath, InStrRev(FilePath, "\") - 1)
If Dir(FolderPath, vbDirectory) <> "" Then
Application.ScreenUpdating = False
sws.Copy
Dim dws As Worksheet: Set dws = ActiveWorkbook.Worksheets(1)
dws.UsedRange.Value = dws.UsedRange.Value
Application.DisplayAlerts = False
dws.Parent.SaveAs FilePath, xlOpenXMLWorkbook
Application.DisplayAlerts = True
dws.Parent.Close False
Application.ScreenUpdating = True
MsgBox "Backup of worksheet '" & swsName & "' created as '" _
& FilePath & "'.", vbInformation, "Success"
Else
MsgBox "The Folder '" & FolderPath & "' does not exist.", _
vbCritical, "Fail"
End If
End Sub
First: for disc C path must start from "C:\", in your case:
"C:\Folder1\Folder2\Folder3\YYYY\MM\DD"
Second: you must save file to already existing folder, for your case you must split path by "\" and check existence of all subfolders.
Related
I have a workbook with filtered ranges on each sheet. I have tried a couple different methods but when stepping through it only does the first sheet or none at all. This is what I have tried.
dim ws as worksheet
For Each Ws In ThisWorkbook.Worksheets
If Ws.AutoFilterMode Then
Ws.AutoFilter.ShowAllData
End If
Next Ws
this one isn't doing anything at all
this one is less sophisticated and not what I want.
For Each ws In ThisWorkbook.Worksheets
Rows("1:1").Select
Selection.AutoFilter
Next ws
this is only doing the first worksheet and not moving to the next.
this is the full code and it is not returning any errors
Sub Cleanup()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim mergedWb As Workbook
Set mergedWb = Workbooks.Add()
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Dim ws As Worksheet
Application.ScreenUpdating = False
FolderPath = "<folder path>"
Filename = Dir(FolderPath & "*.xls*")
Do While Filename <> ""
Dim wb As Workbook
Set wb = Workbooks.Open(Filename:=FolderPath & Filename, ReadOnly:=True)
For Each Sheet In wb.Sheets
Sheet.Copy After:=mergedWb.Sheets(1)
Next Sheet
wb.Close
Filename = Dir()
Loop
Sheets(1).Delete
For Each ws In ThisWorkbook.Worksheets
If ws.AutoFilterMode Then
ws.AutoFilter.ShowAllData
End If
Next ws
End Sub
Copy Sheets to New Workbook
Issues
ThisWorkbook is the workbook containing this code. It has nothing to do with the code so far: you're adding a new (destination) workbook (mergedWb) and you're opening (source) files ('wb') whose sheets (Sheet) will be copied. Instead, you should use:
For Each ws In mergedWb.Worksheets
When you use the Sheets collection, you need to keep in mind that it also includes charts. Therefore, you should declare:
Dim Sheet As Object
You need to qualify the first destination (work)sheet to ensure the correct worksheet is deleted:
Application.DisplayAlerts = False ' delete without confirmation
mergedWb.Sheets(1).Delete
Application.DisplayAlerts = True
To turn off the auto filter, you need to use:
dws.AutoFilterMode = False
You can avoid the loop by copying all sheets (that are not very hidden) at once (per workbook):
swb.Sheets.Copy After...
The line swb.Sheets.Copy (no arguments) copies all sheets (that are not very hidden) to a new workbook.
The Code
Option Explicit
Sub Cleanup()
Const SOURCE_FOLDER_PATH As String = "C:\Test"
Const SOURCE_FILE_PATTERN As String = "*.xls*"
If Not CreateObject("Scripting.FileSystemObject") _
.FolderExists(SOURCE_FOLDER_PATH) Then
MsgBox "The folder '" & SOURCE_FOLDER_PATH & "' doesn't exist.", _
vbCritical
Exit Sub
End If
Dim sFolderPath As String: sFolderPath = SOURCE_FOLDER_PATH
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
Dim sFileName As String: sFileName = Dir(sFolderPath & SOURCE_FILE_PATTERN)
If Len(sFileName) = 0 Then
MsgBox "No files found."
Exit Sub
End If
Dim swb As Workbook
Dim dwb As Workbook
Dim sFilePath As String
Dim IsNotFirstSourceWorkbook As Boolean
Application.ScreenUpdating = False
Do While Len(sFileName) > 0
sFilePath = sFolderPath & sFileName
Set swb = Workbooks.Open(Filename:=sFilePath, ReadOnly:=True)
If IsNotFirstSourceWorkbook Then
swb.Sheets.Copy After:=dwb.Sheets(dwb.Sheets.Count)
Else
swb.Sheets.Copy ' creates a new workbook containing the sheets
Set dwb = Workbooks(Workbooks.Count)
IsNotFirstSourceWorkbook = True
End If
swb.Close SaveChanges:=False
sFileName = Dir()
Loop
Dim dws As Worksheet
For Each dws In dwb.Worksheets
If dws.AutoFilterMode Then dws.AutoFilterMode = False
Next dws
' Decide what to do with the new workbook e.g.:
' Application.DisplayAlerts = False ' overwrite without confirmation
' dwb.SaveAs sFolderPath & "CleanUp " & Format(Date, "yyyymmdd")
' Application.DisplayAlerts = True
' dwb.Close SaveChanges:=False ' it has just been saved
Application.ScreenUpdating = True
MsgBox "Cleaned up.", vbInformation
End Sub
i have an issue with this code. I need to save the data from a workbook to a new workbook but the new workbook doesn't save, I do it manually. I need it to save automatically. Any idea what is going on?
this is my code so far
Private Sub CommandButton3_Click()
Dim wb As Workbook
Dim wb_New As Workbook
Set wb = ThisWorkbook
Dim wbstring As String
Dim input_file_name As String
input_file_name = InputBox("Enter file name", "Enter new workbook file name")
wbstring = "C:\PIME\\"
Workbooks.Add.SaveAs Filename:=wbstring & input_file_name & ".xls", FileFormat:=56
Set wb_New = ActiveWorkbook
wb_New.Worksheets("Sheet1").Range("A1:I2000").Value = wb.Worksheets("NUMB").Range("A1:I2000").Value
End Sub
You got it almost right - Set wb_New to the new workbook, populate the data then use SaveAs method.
Set wb_New = Workbooks.Add
wb_New.Worksheets("Sheet1").Range("A1:I2000").Value = wb.Worksheets("NUMB").Range("A1:I2000").Value
wb_New.SaveAs Filename:=wbstring & input_file_name & ".xls", FileFormat:=56
Copy a Range to a New One-Worksheet Workbook
The only mistake I could find was that you need to remove one of the two trailing backslashes from the path:
wbstring = "C:\PIME\"
An Improvement
Option Explicit
Private Sub CommandButton3_Click()
' Source
Dim swb As Workbook: Set swb = ThisWorkbook
Dim sws As Worksheet: Set sws = swb.Worksheets("NUMB")
' Destination
Dim dFolderPath As String: dFolderPath = "C:\PIME\"
If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
Dim dExtension As String: dExtension = ".xls"
If Left(dExtension, 1) <> "." Then dExtension = "." & dExtension
If Len(Dir(dFolderPath, vbDirectory)) = 0 Then
MsgBox "The path '" & dFolderPath & "' doesn't exist.", vbCritical
Exit Sub
End If
Dim dFileName As String
dFileName = InputBox("Enter file name", "Enter new workbook file name")
If Len(dFileName) = 0 Then
MsgBox "Canceled or no entry."
Exit Sub
End If
Dim dwb As Workbook: Set dwb = Workbooks.Add(xlWBATWorksheet) ' single...
Dim dws As Worksheet: Set dws = dwb.Worksheets(1) ' ... worksheet,...
' ... in another language it may not be 'Sheet1'.
' Copy by Assignement (the most efficient way to copy only values)
dws.Range("A1:I2000").Value = sws.Range("A1:I2000").Value
' Save(As)
Dim dFilePath As String: dFilePath = dFolderPath & dFileName & dExtension
Dim ErrNum As Long
Application.DisplayAlerts = False ' overwrite without confirmation
On Error Resume Next
dwb.SaveAs Filename:=dFilePath, FileFormat:=xlExcel8 ' or 56
ErrNum = Err.Number
On Error GoTo 0
Application.DisplayAlerts = True
' Close
dwb.Close SaveChanges:=False
' Inform
If ErrNum = 0 Then
MsgBox "File saved.", vbInformation
Else
MsgBox "Could not save the file.", vbCritical
End If
End Sub
You may tweak your code as below...
Workbooks.Add.SaveAs Filename:=wbstring & input_file_name & ".xls", FileFormat:=56
Set wb_New = ActiveWorkbook
wb_New.Worksheets("Sheet1").Range("A1:I2000").Value = wb.Worksheets("NUMB").Range("A1:I2000").Value
'Then either use wbNew.Save or wbNew.Close True as per your need
wbNew.Save 'To save the work and leave the new workbook open
'OR
wbNew.Close True 'To save the work and close the new workbook.
Hi I have main excel file with 10 sheets (sheet1...sheet10), and i need help with extracting (create new folder with sheet name) sheet5 and sheet6 in folder which link is in sheet1 n6 cell, and sheet7 and sheet8 in folder which link is in sheet1 n7 cell.sheets must be extracted without macros and formulas, only paste as values. For now i only have this which is creating workbooks in main file folder, i dont know how to setup extracting in diferent folders.
Private Sub CommandButton2_Click()
Dim xWs As Worksheet
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("Done.")
End Sub
Export Single Worksheets to Workbooks
Option Explicit
Private Sub CommandButton2_Click()
Const lName As String = "Sheet1"
' The following two lines are dependent on each other.
Dim dExtension As String: dExtension = ".xlsx"
Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
Dim lCellAddresses As Variant: lCellAddresses = Array("N6", "N7")
Dim dNames As Variant: dNames = Array( _
Array("Sheet5", "Sheet6"), _
Array("Sheet7", "Sheet8"))
Dim swb As Workbook: Set swb = ThisWorkbook
Dim lws As Worksheet: Set lws = swb.Worksheets(lName)
Application.ScreenUpdating = False
Dim dwb As Workbook
Dim sws As Worksheet
Dim dFilePath As String
Dim n As Long
For Each sws In swb.Worksheets
For n = LBound(dNames) To UBound(dNames)
If IsNumeric(Application.Match(sws.Name, dNames(n), 0)) Then
sws.Copy
Set dwb = ActiveWorkbook
With dwb.Worksheets(1).UsedRange
.Value = .Value
End With
dFilePath = CStr(lws.Range(lCellAddresses(n)).Value)
If Right(dFilePath, 1) <> "\" Then dFilePath = dFilePath & "\"
If Left(dExtension, 1) <> "." Then dExtension = "." & dExtension
dFilePath = dFilePath & sws.Name & dExtension
Application.DisplayAlerts = False ' overwrite: no confirmation
dwb.SaveAs Filename:=dFilePath, FileFormat:=dFileFormat
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False
Exit For
End If
Next n
Next sws
Application.ScreenUpdating = True
MsgBox "Worksheets exported.", vbInformation
End Sub
I currently import sheets of data into excel that I am exporting from CAD. This includes summaries, counts and other data. I would like to add to the code so that it will import a file from a predetermined directory C:\Jobs\packlist and using a number inside a cell ='PL CALC'!B1 (this will determine the file name). The idea being to remove the open dialog box and increase automation.
This is what I have found that works so far. It opens a selected file and copies it into the workbook after sheet 18.
'import excel data sheet
Sub import()
Dim fName As String, wb As Workbook
'where to look for the framecad excel file
ChDrive "C:"
ChDir "C:\Jobs\packlist"
fName = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*")
Set wb = Workbooks.Open(fName)
For Each sh In wb.Sheets
Sheets.Copy After:=ThisWorkbook.Sheets(18)
Exit For
Next
wb.Close False
Worksheets("PL CALC").Activate
End Sub
Import Sheets
Option Explicit
Sub ImportSheets()
Const ProcTitle As String = "Import Sheets"
Const sFolderPath As String = "C:\Jobs\packlist\"
Const sfnAddress As String = "B1"
Const sFileExtensionPattern As String = ".xls*"
Const dwsName As String = "PL CALC"
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets(dwsName)
Dim sFilePattern As String: sFilePattern = sFolderPath & "*" _
& dws.Range(sfnAddress).Value & sFileExtensionPattern
Dim sFileName As String: sFileName = Dir(sFilePattern)
If Len(sFileName) = 0 Then
MsgBox "No file found..." & vbLf & "'" & sFilePattern & "'", _
vbCritical, ProcTitle
Exit Sub
End If
Application.ScreenUpdating = False
Dim swb As Workbook: Set swb = Workbooks.Open(sFolderPath & sFileName)
Dim sh As Object
For Each sh In swb.Sheets
sh.Copy After:=dwb.Sheets(dwb.Sheets.Count)
Next sh
swb.Close SaveChanges:=False
dws.Activate
'dwb.Save
Application.ScreenUpdating = True
MsgBox "Sheets imported.", vbInformation, ProcTitle
End Sub
Thanks in advance for helping!
I am currently using the below code to populate multiple .csv files into one sheet and then hide the sheet. The help I need is to remove duplicate rows from that sheet. Can it be incorporated into this code? Thank you!
Sub ImportCSVsWithReference()
'UpdatedforSPSS
Dim xSht As Worksheet
Dim xWb As Workbook
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select the folder with the csv files [File Picker]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
Set xSht = Sheets.Add
ActiveSheet.Name = "ImportedData"
Worksheets("ImportedData").Visible = False
Application.ScreenUpdating = False
xFile = Dir(xStrPath & "\" & "*.csv")
Do While xFile <> ""
Set xWb = Workbooks.Open(xStrPath & "\" & xFile)
ActiveSheet.UsedRange.Copy xSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
xWb.Close False
xFile = Dir
Loop
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox "Encountered an error. Try again", , "Error"
End Sub
There is actually a built-in function to remove duplicates from a range. It is called RemoveDuplicates...
Let's look at an example. I assume here that -
The table has 3 columns
The table has 100 rows
The table does not have a header line
Then the code to remove duplicates will look something like:
ActiveSheet.Range("A1:C100").RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
See the docs at https://learn.microsoft.com/en-us/office/vba/api/excel.range.removeduplicates
Do Not Import Headers After the First Imported Worksheet
s - Source (read from)
d - Destination (written to)
The Code
Option Explicit
Sub ImportCSVsWithReference()
Const ProcName As String = "ImportCSVsWithReference"
'On Error GoTo clearError
Const WorksheetName As String = "ImportedData"
Const HeaderRows As Long = 1
' Get Folder Path.
Dim FolderPath As String
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.AllowMultiSelect = False
'.InitialFileName = "C:\Test" ' consider using this
.Title = "Select the folder with the csv files [File Picker]"
If .Show = -1 Then
FolderPath = .SelectedItems(1)
Else
GoTo ProcExit ' Exit Sub
End If
End With
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Application.ScreenUpdating = False
' Define Destination Worksheet (delete existing, add new).
On Error Resume Next
Dim dws As Worksheet: Set dws = dwb.Worksheets(WorksheetName)
On Error GoTo 0
If Not dws Is Nothing Then ' it already exists
Application.DisplayAlerts = False
dws.Delete ' delete without confirmation
Application.DisplayAlerts = True
End If
Set dws = dwb.Worksheets.Add(After:=dwb.Sheets(dwb.Sheets.Count)) ' Sheets!
dws.Name = WorksheetName
dws.Visible = xlSheetHidden ' xlSheetVeryHidden (a 'tougher' option)
' Define Destination Cell.
Dim dCell As Range: Set dCell = dws.Range("A1")
' Copy data from Source Worksheets to Destination Worksheet.
Dim FileName As String: FileName = Dir(FolderPath & "\" & "*.csv")
Dim sws As Worksheet
Dim srg As Range
Dim swsCount As Long
Do While FileName <> ""
' There is only one worksheet in a csv file (the first):
Set sws = Workbooks.Open(FolderPath & "\" & FileName).Worksheets(1)
Set srg = sws.UsedRange
If srg.Rows.Count > HeaderRows Then
swsCount = swsCount + 1
If swsCount > 1 Then ' headers for the first worksheet only
Set srg = srg.Resize(srg.Rows.Count - HeaderRows) _
.Offset(HeaderRows)
End If
dCell.Resize(srg.Rows.Count, srg.Columns.Count).Value _
= srg.Value
Set dCell = dCell.Offset(srg.Rows.Count)
End If
sws.Parent.Close False ' the workbook is the 'parent' of the worksheet
FileName = Dir
Loop
'dwb.save
ProcExit:
If Application.ScreenUpdating = False Then
Application.ScreenUpdating = True
End If
' Inform.
Select Case swsCount
Case 0
MsgBox "No worksheet imported.", vbExclamation, "Fail?"
Case 1
MsgBox "1 worksheet imported.", vbInformation, "Success"
Case Else
MsgBox swsCount & " worksheets imported.", vbInformation, "Success"
End Select
Exit Sub
clearError:
MsgBox "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Sub