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
Related
I'm new to VBA and I'm working on a project. I've searched around the internet and managed to put something together using others' examples. The basic idea is that the code copies user-selected data to a single master workbook. This is what I have so far;
Sub SelectOpenCopy()
Dim vaFiles As Variant
Dim i As Long
Dim DataBook As Workbook
Dim DataSheet As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
vaFiles = Application.GetOpenFilename(Title:="Select files", MultiSelect:=True)
If IsArray(vaFiles) Then
For i = LBound(vaFiles) To UBound(vaFiles)
Set DataBook = Workbooks.Open(FileName:=vaFiles(i))
For Each DataSheet In ActiveWorkbook.Sheets
DataSheet.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Next DataSheet
DataBook.Close savechanges:=False
Next i
End If
End Sub
Two problems with this is that:
If I run the code again and select the same files, new worksheets are made in the master workbook and that isn't what I'm going for. If those worksheets already exist, I want them to be updated instead of new ones being made. If it helps to mention, all the workbooks that need to be copied to the master file only have one worksheet each and the worksheet name matches its workbook too.
The code copies all the data, but I only need a set range ("A1:L1000").
There's a lot I don't understand about VBA, so any and all help is really appreciated!
...
Const CopyAddress = "A1:L1000"
Dim MasterSheet As Worksheet, SheetName As String, SheetExists As Boolean
...
For Each DataSheet In DataBook.Worksheets
SheetName = DataSheet.Name
SheetExists = False
For Each MasterSheet In ThisWorkbook.Worksheets
If MasterSheet.Name = SheetName Then
SheetExists = True
Exit For
End If
Next MasterSheet
If SheetExists Then
DataSheet.Range(CopyAddress).Copy MasterSheet.Range(CopyAddress).Cells(1, 1)
Else
DataSheet.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
End If
Next DataSheet
...
When you run it, don't forget to change the path for the target workbook.
Sub moveData()
'turn off unnecessary applications to make the macro run faster
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim target_wb As Workbook
Dim main_wb As Workbook
Dim file_sheet As Worksheet
Dim exists As Boolean
Dim next_empty_row As Long
Dim R As Range
Dim sheet_name As String
Set main_wb = ThisWorkbook
Set R = _
Application.InputBox("please select the data range:", "Kutools for Excel", , , , , , 8)
sheet_name = ActiveSheet.Name
R.Select
Selection.copy
'workbook path to paste in
Set target_wb = _
Workbooks.Open("/Users/user/Desktop/target.xlsx")
For Each file_sheet In target_wb.Sheets
Application.DisplayAlerts = False
If file_sheet.Name = main_wb.ActiveSheet.Name Then
exists = True
Exit For
Else
exists = False
End If
Next file_sheet
If exists = False Then
target_wb.Sheets.Add.Name = sheet_name
End If
next_empty_row = _
target_wb.Sheets(sheet_name).Cells(Rows.Count, 1).End(xlUp).Row + 1
target_wb.Sheets(sheet_name).Cells(next_empty_row, 1).PasteSpecial
target_wb.Save
target_wb.Close
'turn on applications
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
End Sub
I've got a workbook where I am creating a button that allows to save two specific sheets without formula's (the purpose being that the sheets are going to be send to partners and costumers). I would like the sheets to be saved in a single document somewhere on my computer, and still have the current "design" with colors, setup etc.
I've currently written this code, which does everything that I've described, except deleting the formulas...
Sub SaveAsValues()
Dim ws As Worksheet
Worksheets(Array("frontpage", "mobile")).Copy After:= ws.Worksheets
With ActiveWorkbook
.SaveAs Filename:= "C:XXXX" & "NAME", FileFormat:= xlOpenXMLWorkbook
.Close savechanges = False
End With
End Sub
Hope you can help :-)
I have a sheet I use something similar for, I'll adjust the code a bit to work with your scenario. If you don't want the settings to change, delete the TurnOnFunctions & TurnOffFunctions subs.
This code will only break the links, not necessarily all the formulas. So if a formula references another spreadsheet it will be a static value; however, if it is a simple formula that stays within the spreadsheet it will stay that way.
Also add your workbook name to the respective area.
Sub NewWorkbooks()
'This will make seperate workbooks for each of the tabs listed
Dim wb As Workbook
Dim NewBook As Workbook
Dim ws As Worksheet
Call TurnOffFunctions
Set wb = ActiveWorkbook
For Each ws In Workbooks("YOUR WORKBOOK NAMR"). _
Worksheets(Array("frontpage", "mobile"))
ws.Copy
Set NewBook = ActiveWorkbook
With NewBook
Call break_links(NewBook)
.SaveAs Filename:="C:XXXX" & "NAME", FileFormat:=xlOpenXMLWorkbook
.Close SaveChanges:=False
End With
Next
Call TurnOnFunctions
End Sub
Sub break_links(ByRef wb As Workbook)
Dim Links As Variant
On Error Resume Next
Links = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
On Error GoTo 0
If Not IsEmpty(Links) Then
For i = 1 To UBound(Links)
wb.BreakLink _
Name:=Links(i), _
Type:=xlLinkTypeExcelLinks
Next i
End If
End Sub
Private Sub TurnOffFunctions()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
End Sub
Private Sub TurnOnFunctions()
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
You can use yours too with this mod (untested):
Sub SaveAsValues()
Dim ws As Worksheet
Worksheets(Array("frontpage", "mobile")).Copy After:= ws.Worksheets
Call break_links ActiveWorkbook
With ActiveWorkbook
.SaveAs Filename:= "C:XXXX" & "NAME", FileFormat:= xlOpenXMLWorkbook
.Close savechanges = False
End With
End Sub
Sub break_links(ByRef wb As Workbook)
Dim Links As Variant
On Error Resume Next
Links = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
On Error GoTo 0
If Not IsEmpty(Links) Then
For i = 1 To UBound(Links)
wb.BreakLink _
Name:=Links(i), _
Type:=xlLinkTypeExcelLinks
Next i
End If
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.
I use the following code to import multiple worksheets from another workbook and do some processing. the Importing time is too long. can any one suggest a more efficient way to import? Should I be looking in to more information in the source files for copy?
Sub SKR_Import()
On Error GoTo errorhandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sht As Worksheet
Set wb1 = ActiveWorkbook
Dim fd As FileDialog
Dim filechosen As Integer
Dim filename As String
Dim i As Long
Set fd = Application.FileDialog(msoFileDialogOpen)
fd.AllowMultiSelect = True
fd.Title = "Select Excel workbooks to import all sheets"
filechosen = fd.Show
If filechosen = -1 Then
For i = 1 To fd.SelectedItems.Count
Set wb2 = Workbooks.Open(fd.SelectedItems(i))
For Each Sht In wb2.Sheets
Sht.Activate
ActiveSheet.Copy after:=wb1.Sheets(wb1.Sheets.Count)
Next Sht
wb2.Close SaveChanges:=False
Next i
End If
wb1.Activate
Application.ScreenUpdating = True
Exit Sub
errorhandler:
msgBox Error, vbCritical, "Error"
wb2.Close SaveChanges:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Instead of looping on the sheets of wb2, you can try to copy them at once using the copy method of sheets (with an s):
Set wb2 = Workbooks.Open(fd.SelectedItems(i))
' For Each Sht In wb2.Sheets
' Sht.Activate
' ActiveSheet.Copy after:=wb1.Sheets(wb1.Sheets.Count)
' Next Sht
wb2.Sheets.Copy after:=wb1.Sheets(wb1.Sheets.Count)
wb2.Close SaveChanges:=False
This will also get rid of the Activate statement, which wasn't necessary but only wasted some time.
I dont seem to find other ways to accelerate further your code.
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