My current code opens the XLS file perfectly but we now receive the files in xlsm format. I have tried to simply change the code from .xls to .XLSM but it reports that the file cannot be found.
Here is the current code:
Sub CopyRangeToAnotherSheet()
Dim wbTarget As Workbook
Dim wbThis As Workbook
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wbThis = ActiveWorkbook
Set wbThis = Workbooks.Open(Range("Z1") & Range("AA1") & ".xls")
Sheets("Sheet1").Range("a1:m10000").Copy
Set wbTarget = ThisWorkbook
wbTarget.Sheets("Sheet1").Range("a1").PasteSpecial
Paste:=xlPasteValues
Sheets("sheet1").Activate
Application.CutCopyMode = False
wbThis.Close
Sheets("Menu Tab").Activate
End Sub
Any help appreciated!
Try catching the error and trying the new extension:
Sub CopyRangeToAnotherSheet()
Dim wbTarget As Workbook
Dim wbThis As Workbook
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wbThis = ActiveWorkbook
On Error Goto open_xlsm
Set wbThis = Workbooks.Open(Range("Z1") & Range("AA1") & ".xls")
On Error Goto 0 ' resume normal error "handling"
Goto open_done
open_xlsm:
On Error Goto 0
Set wbThis = Workbooks.Open(Range("Z1") & Range("AA1") & ".xlsm")
open_done:
Sheets("Sheet1").Range("a1:m10000").Copy
Set wbTarget = ThisWorkbook
wbTarget.Sheets("Sheet1").Range("a1").PasteSpecial
Paste:=xlPasteValues
Sheets("sheet1").Activate
Application.CutCopyMode = False
wbThis.Close
Sheets("Menu Tab").Activate
End Sub
This will check for the files foo.xsl and foo.xslm, in that order.
Related
I have made the following code for moving sheet from one WB to another New WB.
However I am experiencing errors.
Sub MoveSheets01()
Dim ws As Worksheet
Dim newWB As Workbook
Dim oldwb As Workbook
Application.ScreenUpdating = False
Set oldwb = ActiveWorkbook
Set newWB = Application.Workbooks.Add
oldwb.Activate
For Each ws In oldwb.Sheets
If ws.Name <> "Input" And ws.Name <> "Output" Then
Application.DisplayAlerts = False
ws.Copy after:=newWB.Sheets(newWB.Sheets.Count)
ws.Delete
Application.DisplayAlerts = True
End If
Next ws
oldwb.Save
newWB.Activate
Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Application.DisplayAlerts = True
newWB.SaveAs Filename:=oldwb.Path & "\AAA " & Format(Now(), "DD.MMM.YYYY hh.mm AMPM") & ".xlsx", CreateBackup:=False
End Sub
It generates a new WB.
But the moment I save either, the file crashes.
Try this. See comments, especially regarding the filename. Most likely you have too long filename. If error occurs - post a comment with error text.
Sub MoveSheets010()
Dim ws As Worksheet
Dim newWB As Workbook
Dim oldwb As Workbook
Dim link As Variant
' switch this off for the whole sub
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Set oldwb = ThisWorkbook
For Each ws In oldwb.Sheets
If ws.Name <> "Input" And ws.Name <> "List" _
And ws.Name <> "Temp" And ws.Name <> "Index Data" _
And ws.Name <> "Ratio's" And ws.Name <> "Total Returns Index" _
And ws.Name <> "India VIX" And ws.Name <> "Output" Then
' check whether newWB is assigned
If Not newWB Is Nothing Then
' if assigned - just add sheet there
ws.Move before:=newWB.Sheets(1)
Else
' if not assign - create new workbook by moving the sheet
' this creates new workbook with only one sheet
' so there will be no "Sheet1", "Sheet2", etc
ws.Move
' assign newWB
Set newWB = ActiveWorkbook
End If
End If
Next
Set ws = Nothing
' save new wb first to avoid message about links/references
newWB.SaveAs Filename:=oldwb.Path & "\AAA " & Format(Now(), "DD.MMM.YYYY hh.mm AMPM") & ".xlsx", CreateBackup:=False
' remove references from source wb and save it
With oldwb
If Not IsEmpty(.LinkSources(xlExcelLinks)) Then
For Each link In .LinkSources(xlExcelLinks)
.BreakLink link, xlLinkTypeExcelLinks
Next link
End If
.Save
End With
' switch this on back
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
In need of importing an Excel Workbook to the sheets of existing Excel Macro-Enabled Workbook
Have been successful in importing it using the code which the destination is specified I used ".xlsx" as the destination since "*" is used to specify all xlsx file found in the folder.
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 & "\*.xlsx") '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
The error is "Run-time error '1004': Sorry, we couldn't find C:\Users\ZMOLD01\Desktop\CaseStudy Results*.xlsx. Is it possible it was moved, renamed or deleted?
Dir gives you the file name if it is found in the Destination.
Change:
Set SourceWB = Workbooks.Open(WB.Path & "\*.xlsx")
To:
If Len(Dir(wb.path & "\*.xlsx")) > 0 Then
Set SourceWB = Workbooks.Open(wb.path & "\" & Dir(wb.path & "\*.xlsx"))
Else: Msgbox "File Not Found"
End if
I'm saving a workbook as a copy with date.
I did it with the code suggested on this site (save as copy).
Now I'm getting an error concerning the links in my new workbook. Is there a way to set the correct links (on the new workbook) to the new workbook together with the save as copy method?
Sub Button15_Click()
ActiveWorkbook.Save
'https://stackoverflow.com/questions/18899824/how-to-use-vba-saveas-without-closing-calling-workbook
'SaveAsCopy
Dim thisWb As Workbook, wbTemp As Workbook
Dim ws As Worksheet
On Error GoTo Whoa
Application.DisplayAlerts = False
Set thisWb = ThisWorkbook
Set wbTemp = Workbooks.Add
On Error Resume Next
For Each ws In wbTemp.Worksheets
ws.Delete
Next
On Error GoTo 0
For Each ws In thisWb.Sheets
ws.Copy After:=wbTemp.Sheets(1)
Next
wbTemp.Sheets(1).Delete
'wbTemp.SaveAs "C:\Users\Me\Desktop\FileName & Format(CStr(Now), dd-mm-yy-hhumm).xlsm", 52 'Save as timestamp
wbTemp.SaveAs ("C:\Users\Me\Desktop\") & "FileName" & Format(Now, "dd-mm-yy-hhumm") & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
LetsContinue:
Application.DisplayAlerts = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
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 have a macro that I used for importing data from many excel workbooks in a directory. It worked just fine in Excel 2003 but since I've recently been upgraded to Excel 2010 the macro doesn't seem to work. When activated the macro doesnt error out or produce anything. I've changed all the Trust Center Settings and other macros I have (not importing data macros) work just fine. I am not very skilled at writing VBA and cannot see where an issue may lie. It just seems like excel trys to run the macro and skips everything it once did and finishes. Any help is greatly appreciated. Thank you
Sub GDCHDUMP()
Dim lCount As Long
Dim wbResults As Workbook
Dim twbk As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
Set twbk = ThisWorkbook
With Application.FileSearch
.NewSearch
'Change path to suit
.LookIn = "R:\ServCoord\GCM\Data Operations\Quality\GDCHDump"
.filename = "*.xls*"
If .Execute > 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count 'Loop through all
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(filename:=.FoundFiles(lCount), UpdateLinks:=0)
Set ws = wbResults.Sheets(1)
ws.Range("B2").Copy
twbk.Sheets(1).Cells(lCount, 1).PasteSpecial xlPasteValues
wbResults.Close SaveChanges:=False
'There was a lot more lines like the 2 above that I removed for clarity
Next lCount
End If
End With
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
On Error Resume Next should be really avoided unless needed. It's like telling Excel to Shut Up.
The main problem is that Application.FileSearch is not supported in xl2007+
You can use Application.GetOpenFilename instead.
See this example. (UNTESTED)
Option Explicit
Sub GDCHDUMP()
Dim lCount As Long
Dim wbResults As Workbook, twbk As Workbook
Dim ws As Worksheet
Dim strPath As String
Dim Ret
Dim i As Long
strPath = "R:\ServCoord\GCM\Data Operations\Quality\GDCHDump"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Set twbk = ThisWorkbook
ChDir strPath
Ret = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , , , True)
If TypeName(Ret) = "Boolean" Then Exit Sub
For i = LBound(Ret) To UBound(Ret)
Set wbResults = Workbooks.Open(Filename:=Ret(i), UpdateLinks:=0)
Set ws = wbResults.Sheets(1)
ws.Range("B2").Copy
'twbk.Sheets(1).Cells(lCount, 1).PasteSpecial xlPasteValues
wbResults.Close SaveChanges:=False
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub