Hello and thank you for your time, in the function code below, how do I make it in a way that it will function on any users computer, not just mine.
I know I need to probably use the Environ("USERPROFILE") thing but I don't know how to incorporate it in the code below.
Function Import_Data() As Boolean
Dim x As Workbook
Dim targetWorkbook As Workbook
Dim xWs As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Const F_PATH As String = "C:\Users\mohammad.reza\Desktop\MyFiles.xls"
'if no file then exit and return false
If Dir(F_PATH) = "" Then
MsgBox "My Files is not found on your Desktop"
Import_Data = False
Exit Function
End If
'If the file exists than load the file and continue
Import_Data = True
' This part delets all sheets except the summary tab
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Summary" Then
xWs.Delete
End If
Next
' This part will get the raw data from the downloaded file on the desktop
Set x = Workbooks.Open("C:\Users\mohammad.reza\Desktop\MyFiles.xls")
Set targetWorkbook = Application.ActiveWorkbook
' This part will copy the sheet into this workbook
With x.Sheets("MyFiles").UsedRange
ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Range("A1").Resize( _
.Rows.Count, .Columns.Count) = .Value
End With
x.Close
' This part will rename the sheet and move it to the end
ActiveSheet.Name = "RAW DATA"
ActiveSheet.Move After:=Worksheets(Worksheets.Count)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function
Thank you brad for your answer, however when I use it, it gives the below error:
Try this ...
Function Import_Data() As Boolean
Dim x As Workbook
Dim targetWorkbook As Workbook
Dim xWs As Worksheet
Dim sPath As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
sPath = Environ("USERPROFILE") & "\Desktop\MyFiles.xls"
'if no file then exit and return false
If Dir(sPath) = "" Then
MsgBox "My Files is not found on your Desktop"
Import_Data = False
Exit Function
End If
'If the file exists than load the file and continue
Import_Data = True
' This part delets all sheets except the summary tab
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Summary" Then
xWs.Delete
End If
Next
' This part will get the raw data from the downloaded file on the desktop
Set x = Workbooks.Open(sPath)
Set targetWorkbook = Application.ActiveWorkbook
' This part will copy the sheet into this workbook
With x.Sheets("MyFiles").UsedRange
ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Range("A1").Resize( _
.Rows.Count, .Columns.Count) = .Value
End With
x.Close
' This part will rename the sheet and move it to the end
ActiveSheet.Name = "RAW DATA"
ActiveSheet.Move After:=Worksheets(Worksheets.Count)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function
Related
i'm having a bit of a headache with VBA which i haven't used since 2006.
I have my destination excel file where I need to import 3 predefined sheets from another excel file of the user's choice.
After selecting the source file to import I would like to perform a check, IF the "Cover" sheet exists THEN copy it to the target workbook ELSE print an error message in the excel file in order to have a log, once this is done I have to do the same check for the "Functional" and "Batch" sheets.
Before inserting the IFs, I was able to import the sheets but I didn't have control over whether they existed or not, "Cover" is mandatory while "Functional" and "Batch" I need at least one of the two to be able to proceed with the next steps.
Now I can check if the "Cover" sheet exists and import it ELSE I exit the Sub, after which I should check if the other sheets also exist and import them but I immediately get the "absent sheet" error.
Below is the code I am getting stuck with:
Sub Import()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim TargetWorkbook As Workbook
Dim SourceWorkbook As Workbook
Dim OpenFileName
Set TargetWorestBookkbook = ActiveWorkbook
'Select and Open Source workbook
OpenFileName = Application.GetOpenFilename("Excel Files (*.xls*),*.xls*")
If OpenFileName = False Then
MsgBox "Nessun file Source selezionato. Impossibile procedere."
Exit Sub
End If
On Error GoTo exit_
Set SourceWorkbook = Workbooks.Open(OpenFileName)
'Import sheets
' if the sheet doesn't exist an error will occur here
If WorksheetExists("Cover e Legenda") Then
SourceWorkbook.Sheets("Cover e Legenda").Copy _
after:=TargetWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Application.CutCopyMode = False
SourceWorkbook.Close False
Else
MsgBox ("Cover assente. Impossibile proseguire.")
Exit Sub
End If
If WorksheetExists("Test Funzionali") Then
SourceWorkbook.Sheets("Test Funzionali").Copy _
after:=TargetWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Application.CutCopyMode = False
SourceWorkbook.Close False
Else
MsgBox ("Test Funzionali assente.")
End If
If WorksheetExists("Test Batch") Then
SourceWorkbook.Sheets("Test Batch").Copy _
after:=TargetWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Application.CutCopyMode = False
SourceWorkbook.Close False
Else
MsgBox ("Test Batch assente.")
End If
'Next Sheet
Application.ScreenUpdating = True
Application.DisplayAlerts = True
SourceWorkbook.Close SaveChanges:=False
MsgBox ("Importazione completata.")
TargetWorkbook.Activate
exit_:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
If Err Then MsgBox Err.Description, vbCritical, "Error"
End Sub
Best to check all of the sheets before importing any of them.
Try something like this:
Sub Import()
Dim wbTarget As Workbook, wbSource As Workbook
Dim OpenFileName, haveCover As Boolean, haveFunz As Boolean, haveTest As Boolean
On Error GoTo haveError
Set wbTarget = ActiveWorkbook
'Select and Open Source workbook
OpenFileName = Application.GetOpenFilename("Excel Files (*.xls*),*.xls*")
If OpenFileName = False Then
MsgBox "Nessun file Source selezionato. Impossibile procedere."
Exit Sub
End If
Set wbSource = Workbooks.Open(OpenFileName)
'check which sheets exist
haveCover = WorksheetExists(wbSource, "Cover e Legenda")
haveFunz = WorksheetExists(wbSource, "Test Funzionali")
haveTest = WorksheetExists(wbSource, "Test Batch")
If haveCover And (haveFunz Or haveTest) Then 'have the minumum required sheets?
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ImportSheet wbTarget, wbSource.Worksheets("Cover e Legenda")
If haveFunz Then ImportSheet wbTarget, wbSource.Worksheets("Test Funzionali")
If haveTest Then ImportSheet wbTarget, wbSource.Worksheets("Test Batch")
Application.DisplayAlerts = True
Else
MsgBox "Required sheet(s) not found!", vbExclamation
End If
wbSource.Close SaveChanges:=False
MsgBox "Importazione completata"
wbTarget.Activate
Exit Sub 'normal exit
haveError:
MsgBox Err.Description, vbCritical, "Error"
Application.DisplayAlerts = True
End Sub
'copy sheet `ws` to the end of `wbTarget`
Sub ImportSheet(wbTarget As Workbook, ws As Worksheet)
ws.Copy after:=wbTarget.Worksheets(wbTarget.Worksheets.Count)
End Sub
'does sheet `wsName` exist in workbook `wb` ?
Function WorksheetExists(wb As Workbook, wsName As String) As Boolean
On Error Resume Next
WorksheetExists = Not wb.Worksheets(wsName) Is Nothing
On Error GoTo 0
If Not WorksheetExists Then
'log error to errors sheet
With ThisWorkbook.Worksheets("Import Errors").Cells(Rows.Count, "A").End(xlUp)
.Resize(1, 3).Value = Array(Now, wb.Name, "Sheet '" & wsName & "' not found")
End With
End If
End Function
Import Mandatory and Optional Worksheets
Sub ImportWorksheets()
Dim Mandatory() As Variant: Mandatory = VBA.Array("Cover e Legenda")
Dim Optionally() As Variant ' 'Optional' is a keyword
Optionally = VBA.Array("Test Funzionali", "Test Batch")
Dim twb As Workbook: Set twb = ThisWorkbook ' workbook containing this code
' Select and open the Source workbook.
Dim OpenFilePath As Variant
OpenFilePath = Application.GetOpenFilename("Excel Files (*.xls*),*.xls*")
If OpenFilePath = False Then
MsgBox "Nessun file Source selezionato. Impossibile procedere.", _
vbExclamation
Exit Sub
End If
Dim swb As Workbook: Set swb = Workbooks.Open(OpenFilePath)
' Check if all the mandatory worksheets exist.
Dim sws As Worksheet, n As Long
For n = 0 To UBound(Mandatory)
On Error Resume Next ' prevent error if worksheet doesn't exist
Set sws = swb.Worksheets(Mandatory(n))
On Error GoTo 0
If sws Is Nothing Then
'swb.Close SaveChanges:=False
MsgBox "The mandatory worksheet """ & Mandatory(n) _
& """ was not found in """ & swb.Name & """.", vbCritical
Exit Sub
Else
Set sws = Nothing
End If
Next n
' Check if at least one of the optional worksheets exists.
Dim oDict As Object: Set oDict = CreateObject("Scripting.Dictionary")
oDict.CompareMode = vbTextCompare
For n = 0 To UBound(Optionally)
On Error Resume Next ' prevent error if worksheet doesn't exist
Set sws = swb.Worksheets(Optionally(n))
On Error GoTo 0
If Not sws Is Nothing Then oDict(sws.Name) = Empty: Set sws = Nothing
Next n
If oDict.Count = 0 Then
'swb.Close SaveChanges:=False
MsgBox "No optional worksheets found in """ & swb.Name & """.", _
vbCritical
Exit Sub
End If
' Import the worksheets and close the Source workbook.
Application.ScreenUpdating = False
For n = 0 To UBound(Mandatory)
swb.Sheets(Mandatory(n)).Copy After:=twb.Sheets(twb.Sheets.Count)
Next n
Dim oKey As Variant
For Each oKey In oDict.Keys
swb.Sheets(oKey).Copy After:=twb.Sheets(twb.Sheets.Count)
Next oKey
swb.Close SaveChanges:=False
Application.ScreenUpdating = True
' Inform.
MsgBox "Imported Worksheets" & vbLf & vbLf _
& "Mandatory:" & vbLf & Join(Mandatory, vbLf) & vbLf & vbLf _
& "Optionally:" & vbLf & Join(oDict.Keys, vbLf), vbInformation
End Sub
I have a template file and 4 source documents that I use to fill the template. For each row in sheet2, I create a new blank template and fill it out, resulting in somewhere between 10-100 files. I want to save these in a loop, but having issues with Excel force closing on me. This is my code so far, recycled from a different project.
Dim w As Long, wb As Workbook
Dim fp As String, fn As String
Dim folderName As String
Dim fsoFSO
On Error GoTo bm_Safe_Exit
'Application.ScreenUpdating = False 'stop screen flashing
Application.DisplayAlerts = False 'stop confirmation alerts
'start with a reference to ThisWorkbook
With ThisWorkbook
folderName = Format(Date, "ddmmyyyy")
'set path to save
'fp = "<PATH HERE>" & folderName
fp = "C:\Users\Username\OneDrive - CompanyName\Documents\Projects\ThisProject\csvOutput\" & folderName
Set fsoFSO = CreateObject("Scripting.FileSystemObject")
If fsoFSO.FolderExists(fp) Then
MsgBox "FOLDER - " & fp & " ALREADY EXISTS, DELETE CONTENTS TO PROCEED"
Exit Sub
Else
fsoFSO.CreateFolder (fp)
End If
'cycle through each of the worksheets
For w = 6 To Worksheets.Count
With Worksheets(w)
.Copy
'the ActiveWorkbook is now the new workbook populated with a copy of the current worksheet
With ActiveWorkbook
fn = .Worksheets(1).Name
Cells.Select
Selection.SpecialCells(xlCellTypeVisible).Copy
Worksheets.Add after:=Sheets(Sheets.Count)
Range("A1").Select
ActiveSheet.Paste
Worksheets(1).Delete
Worksheets(1).Name = fn
.SaveAs Filename:=fp & Chr(92) & fn, FileFormat:=51
.Close savechanges:=False '<~~ already saved in line above
End With
End With
Next w
End With
bm_Safe_Exit:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub ```
The code below worked for me: not sure exactly where the problem might vbe with your posted code, but within your With blocks not everything is scope to the block using a leading .
Sub Test()
Dim w As Long, wb As Workbook, wbNew As Workbook
Dim fp As String, fn As String
Dim fsoFSO
On Error GoTo bm_Safe_Exit
Set wb = ThisWorkbook
fp = "C:\Users\Username\OneDrive - CompanyName\Documents\Projects\" & _
"ThisProject\csvOutput\" & Format(Date, "ddmmyyyy") & "\"
Set fsoFSO = CreateObject("Scripting.FileSystemObject")
If fsoFSO.FolderExists(fp) Then
MsgBox "FOLDER - " & fp & " ALREADY EXISTS, DELETE CONTENTS TO PROCEED"
Exit Sub
Else
fsoFSO.CreateFolder fp
End If
'cycle through each of the worksheets
For w = 6 To wb.Worksheets.Count
'explicitly create a new single-sheet workbook as the destination
Set wbNew = Workbooks.Add(Template:=xlWBATWorksheet)
wb.Worksheets(w).Copy before:=wbNew.Sheets(1)
DeleteSheet wbNew.Sheets(2)
With wbNew
fn = .Worksheets(1).Name
.Worksheets.Add after:=.Worksheets(.Worksheets.Count)
.Worksheets(1).Cells.SpecialCells(xlCellTypeVisible).Copy _
Destination:=.Worksheets(2).Range("A1")
DeleteSheet .Worksheets(1)
.Worksheets(1).Name = fn
.SaveAs Filename:=fp & fn, FileFormat:=51
.Close savechanges:=False '<~~ already saved in line above
End With
Next w
Exit Sub
bm_Safe_Exit:
MsgBox Err.Description
End Sub
'utility sub
Sub DeleteSheet(ws As Worksheet)
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End Sub
I am working on a VBA script to allow manipulation and export of a number of worksheets as csv files from an Excel workbook. I'd like to be able to export a list of specified sheets as csv files to a save location that is able to be selected, in addition any cell in a specific column that is blank but may contain a formula needs to be have the entire row deleted. The below script is what I currently have and it seems to work to a point but there are three main issues:
The line below will remove lines if the cell in column A is really blank i.e contains no formula, but does not work if formula is present: Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
The cycling through the sheets is untidy but functional, is there a way to use a list of named sheets to make the script more concise?
Ideally the save location would also be selectable from a choose file directory dialog box. Any suggestions on how to achieve this?
Many thanks in advance.
Sub createCSVfiles()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Declare and set variables
Dim wb1 As Workbook, ws1 As Worksheet
Dim wbname As String, i As Integer
Set wb1 = ThisWorkbook
'Cycle through sheets
For i = 1 To Worksheets.Count
wbname = Worksheets(i).Name
'Create Sheet1.csv
If InStr(1, (Worksheets(i).Name), "Sheet1", vbTextCompare) > 0 Then
Worksheets(i).Copy
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
ActiveWorkbook.SaveAs Filename:="C:\Users\forename.surname\Desktop\export\" & ActiveSheet.Name & ".csv", _
FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
wb1.Activate
End If
'Create Sheet2.csv
If InStr(1, (Worksheets(i).Name), "Sheet2", vbTextCompare) > 0 Then
Worksheets(i).Copy
ActiveWorkbook.SaveAs Filename:="C:\Users\forename.surname\Desktop\export\" & ActiveSheet.Name & ".csv", _
FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
wb.Activate
End If
Next i
'Clean
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I think something like this is what you're looking for:
Sub createCSVfiles()
'Declare and set variables
Dim wb As Workbook
Dim ws As Worksheet
Dim wsTemp As Worksheet
Dim aSheets() As Variant
Dim vSheet As Variant
Dim sFilePath As String
Dim sNewFileName As String
Dim oShell As Object
Dim i As Long
'Select folder to save CSV files to
Set oShell = CreateObject("Shell.Application")
On Error Resume Next
sFilePath = oShell.BrowseForFolder(0, "Select folder to save csv files", 0).Self.Path & Application.PathSeparator
On Error GoTo 0
If Len(sFilePath) = 0 Then Exit Sub 'Pressed cancel
'Define sheet names here
aSheets = Array("Sheet1", "Sheet2")
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set wb = ThisWorkbook
'Cycle through sheets
For Each vSheet In aSheets
'Test if sheet exists
Set ws = Nothing
On Error Resume Next
Set ws = wb.Sheets(vSheet)
On Error GoTo 0
If Not ws Is Nothing Then
'Sheet exists
ws.Copy
Set wsTemp = ActiveSheet
'Remove rows with blanks in column A
With wsTemp.Range("A1", wsTemp.Cells(wsTemp.Rows.Count, "A").End(xlUp))
.AutoFilter 1, "=", xlFilterValues
.Offset(1).EntireRow.Delete
.AutoFilter
End With
'Save and close
wsTemp.Parent.SaveAs sFilePath & wsTemp.Name & ".csv", xlCSV
wsTemp.Parent.Close False
End If
Next vSheet
'Clean
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
I am trying to loop through each Excel file in a folder, to the same sheet to copy the same range to another Excel file.
I had a code but it was not displaying the copy paste correctly (e.g. was showing 1,2479 as 12.479). I looked for a new code and found and enhanced one.
However, for just nine files, this code runs for over three minutes. The folder would have around 50 files, so I am a bit worried that excel won't be able to handle it.
I read a lot about not using .Select, but I believe I am not doing that.
I am using Excel 2010
Original Code
Sub LoopThroughDirectory()
Dim MyFile As String
Dim erow
Dim Filepath As String
'Setting the right folder where the cartographies are
Filepath = "C:\Users\xxx\OneDrive - xxx\Testexcel\"
MyFile = Dir(Filepath)
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
'Application.DecimalSeparator = ","
'Application.ThousandsSeparator = "."
'Application.UseSystemSeparators = False
Do While Len(MyFile) > 0
'If MyFile = "zmaster.xlsm" Then
'Exit Sub
'End If
'Open all the workbook
Workbooks.Open (Filepath & MyFile)
'Activate the right worksheet in the cartography file
Worksheets("xxxxxx").Activate
'Highlight the range of cells we want to copy
Range("E2:H2").Copy
ActiveWorkbook.Close
'Add the copied cells to our sheet in the master file
Worksheets("xxxxxx").Activate
erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Range(Cells(erow, 1), Cells(erow, 4)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlPasteSpecialOperationNone
MyFile = Dir
Loop
'Application.UseSystemSeparators = True
End Sub
Current code
Sub Merge2MultiSheets()
Dim xRg As Range
Dim xSelItem As Variant
Dim FileDlg As FileDialog
Dim FileName, Standalone, Range2copy As String
Dim Cartography As Workbook
Dim TargetSheet As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
'Optimize Code
Call OptimizeCode_Begin
'Give the name of the sheet of cartography where data should be gathered
Standalone = "xxxxxxxx"
'Say the range of the data to be copied from the sheet
Range2copy = "E2:H2"
Set Workbook = ThisWorkbook
Set TargetSheet = Workbook.Sheets("Consolidated Cartography")
'Ask in pop-up where the folder is located with the excel files to update
Set FileDlg = Application.FileDialog(msoFileDialogFolderPicker)
With FileDlg
If .Show = -1 Then
xSelItem = .SelectedItems.Item(1)
FileName = Dir(xSelItem & "\*.xls*", vbNormal)
If FileName = "" Then Exit Sub
Do Until FileName = ""
'Open the first file in the folder
Set Cartography = Workbooks.Open(xSelItem & "\" & FileName)
'Open the right active sheet with data to be copied and put range into xRg
Set xRg = Cartography.Worksheets(Standalone).Range(Range2copy)
'Copy xRg to the TargetSheet at location starting at A250, go up to last row with data then one down
xRg.Copy TargetSheet.Range("A250").End(xlUp).Offset(1, 0)
FileName = Dir()
Cartography.Close
Loop
End If
End With
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
'Optimize Code
Call OptimizeCode_End
End Sub
I found this on the internet. It does try to make code faster by disabling some events and triggers.
Sub OptimizeCode_Begin()
Application.ScreenUpdating = False
EventState = Application.EnableEvents
Application.EnableEvents = False
CalcState = Application.Calculation
Application.Calculation = xlCalculationManual
PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False
End Sub
Sub OptimizeCode_End()
ActiveSheet.DisplayPageBreaks = PageBreakState
Application.Calculation = CalcState
Application.EnableEvents = EventState
Application.ScreenUpdating = True
End Sub
A bit of speed improvement can be gained by counting the target rows instead of finding them in every loop. So in the initialisation phase (out of loop):
Dim iTrgRow As Long
iTrgRow = TargetSheet.Range("A250").End(xlUp).Offset(1, 0).Row
Then in the loop:
Cartography.Worksheets(Standalone).Range(Range2copy).Copy Destination:=TargetSheet.Cells(iTrgRow, 1)
iTrgRow = iTrgRow + 1
This will paste the copy buffer to column A, iTrgRow. It's OK as long as you copy one row of data.
For OptimizeCode collection: I agree with the comments above. Yet, you can turn off DisplayPageBreaks, Calculation, EnableEvents, ScreenUpdating, but I would leave DisplayAlerts on.
So, what I want to do, generally, is make a copy of a workbook. However, the source workbook is running my macros, and I want it to make an identical copy of itself, but without the macros. I feel like there should be a simple way to do this with VBA, but have yet to find it. I am considering copying the sheets one by one to the new workbook, which I will create. How would I do this? Is there a better way?
I would like to slightly rewrite keytarhero's response:
Sub CopyWorkbook()
Dim sh as Worksheet, wb as workbook
Set wb = workbooks("Target workbook")
For Each sh in workbooks("source workbook").Worksheets
sh.Copy After:=wb.Sheets(wb.sheets.count)
Next sh
End Sub
Edit: You can also build an array of sheet names and copy that at once.
Workbooks("source workbook").Worksheets(Array("sheet1","sheet2")).Copy _
After:=wb.Sheets(wb.sheets.count)
Note: copying a sheet from an XLS? to an XLS will result into an error. The opposite works fine (XLS to XLSX)
Someone over at Ozgrid answered a similar question. Basically, you just copy each sheet one at a time from Workbook1 to Workbook2.
Sub CopyWorkbook()
Dim currentSheet as Worksheet
Dim sheetIndex as Integer
sheetIndex = 1
For Each currentSheet in Worksheets
Windows("SOURCE WORKBOOK").Activate
currentSheet.Select
currentSheet.Copy Before:=Workbooks("TARGET WORKBOOK").Sheets(sheetIndex)
sheetIndex = sheetIndex + 1
Next currentSheet
End Sub
Disclaimer: I haven't tried this code out and instead just adopted the linked example to your problem. If nothing else, it should lead you towards your intended solution.
You could saveAs xlsx. Then you will loose the macros and generate a new workbook with a little less work.
ThisWorkbook.saveas Filename:=NewFileNameWithPath, Format:=xlOpenXMLWorkbook
I was able to copy all the sheets in a workbook that had a vba app running, to a new workbook w/o the app macros, with:
ActiveWorkbook.Sheets.Copy
Assuming all your macros are in modules, maybe this link will help. After copying the workbook, just iterate over each module and delete it
Try this instead.
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Copy
Next
You can simply write
Worksheets.Copy
in lieu of running a cycle.
By default the worksheet collection is reproduced in a new workbook.
It is proven to function in 2010 version of XL.
Workbooks.Open Filename:="Path(Ex: C:\Reports\ClientWiseReport.xls)"ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Here is one you might like it uses the Windows FileDialog(msoFileDialogFilePicker) to browse to a closed workbook on your desktop, then copies all of the worksheets to your open workbook:
Sub CopyWorkBookFullv2()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim x As Integer
Dim closedBook As Workbook
Dim cell As Range
Dim numSheets As Integer
Dim LString As String
Dim LArray() As String
Dim dashpos As Long
Dim FileName As String
numSheets = 0
For Each ws In Application.ActiveWorkbook.Worksheets
If ws.Name <> "Sheet1" Then
Sheets.Add.Name = "Sheet1"
End If
Next
Dim fileExplorer As FileDialog
Set fileExplorer = Application.FileDialog(msoFileDialogFilePicker)
Dim MyString As String
fileExplorer.AllowMultiSelect = False
With fileExplorer
If .Show = -1 Then 'Any file is selected
MyString = .SelectedItems.Item(1)
Else ' else dialog is cancelled
MsgBox "You have cancelled the dialogue"
[filePath] = "" ' when cancelled set blank as file path.
End If
End With
LString = Range("A1").Value
dashpos = InStr(1, LString, "\") + 1
LArray = Split(LString, "\")
'MsgBox LArray(dashpos - 1)
FileName = LArray(dashpos)
strFileName = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & FileName
Set closedBook = Workbooks.Open(strFileName)
closedBook.Application.ScreenUpdating = False
numSheets = closedBook.Sheets.Count
For x = 1 To numSheets
closedBook.Sheets(x).Copy After:=ThisWorkbook.Sheets(1)
x = x + 1
If x = numSheets Then
GoTo 1000
End If
Next
1000
closedBook.Application.ScreenUpdating = True
closedBook.Close
Application.ScreenUpdating = True
End Sub
try this one
Sub Get_Data_From_File()
'Note: In the Regional Project that's coming up we learn how to import data from multiple Excel workbooks
' Also see BONUS sub procedure below (Bonus_Get_Data_From_File_InputBox()) that expands on this by inlcuding an input box
Dim FileToOpen As Variant
Dim OpenBook As Workbook
Application.ScreenUpdating = False
FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
If FileToOpen <> False Then
Set OpenBook = Application.Workbooks.Open(FileToOpen)
'copy data from A1 to E20 from first sheet
OpenBook.Sheets(1).Range("A1:E20").Copy
ThisWorkbook.Worksheets("SelectFile").Range("A10").PasteSpecial xlPasteValues
OpenBook.Close False
End If
Application.ScreenUpdating = True
End Sub
or this one:
Get_Data_From_File_InputBox()
Dim FileToOpen As Variant
Dim OpenBook As Workbook
Dim ShName As String
Dim Sh As Worksheet
On Error GoTo Handle:
FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*.xls*")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If FileToOpen <> False Then
Set OpenBook = Application.Workbooks.Open(FileToOpen)
ShName = Application.InputBox("Enter the sheet name to copy", "Enter the sheet name to copy")
For Each Sh In OpenBook.Worksheets
If UCase(Sh.Name) Like "*" & UCase(ShName) & "*" Then
ShName = Sh.Name
End If
Next Sh
'copy data from the specified sheet to this workbook - updae range as you see fit
OpenBook.Sheets(ShName).Range("A1:CF1100").Copy
ThisWorkbook.ActiveSheet.Range("A10").PasteSpecial xlPasteValues
OpenBook.Close False
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
Handle:
If Err.Number = 9 Then
MsgBox "The sheet name does not exist. Please check spelling"
Else
MsgBox "An error has occurred."
End If
OpenBook.Close False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
both work as