I am trying to come up with code that will make copies of all the worksheets in a given workbook. Seems simple enough, right? A little Google searching and I cobbled together the following code:
Sub Commandbutton1_click()
Dim Cnt As Long
Dim i As Long
Dim Sht1 As String
Dim MyChoice As String
Dim MyFile As String
Dim CurrWorkBook As Excel.Workbook
Dim Month As String
'Instructional message box
MsgBox "When the 'Open' dialog appears, select the workbook containing the worksheets you want to split and then click Ok."
'Get file name
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Show
MyChoice = .SelectedItems(1)
End With
Application.ScreenUpdating = False
MyFile = Dir(MyChoice)
Set CurrWorkBook = Workbooks.Open(Filename:=MyFile)
CurrWorkBook.Activate
Cnt = Sheets.Count
InputMsg = "Enter the month of the EOM Budget Review:"
InputTitle = "Month"
Month = InputBox(InputMsg, InputTitle)
For i = 1 To Cnt Step 1
Sht1 = Sheets(i).Name
Sheets(Array(Sht1)).Copy
ActiveWorkbook.SaveAs Filename:=Sht1 & " - " & Month & " EOM Budget Review.xlsx", _
FileFormat:=51, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close
Next i
CurrWorkBook.Save
CurrWorkBook.Close
Application.ScreenUpdating = True
End Sub
It works perfectly...except when it doesn't. In some workbooks, it will copy every sheet with no difficulty. In some workbooks, it will copy some of the sheets, but throw the "Copy method of Sheets class failed" unless you have it skip certain sheets. I have not been able to figure out what the sheets it will not copy have in common. Is there some way I can improve this code? Are there certain features of worksheets that will cause this kind of code to fail inevitably?
Solved thanks to Alex P.'s comment above. I copied the following code from another forum:
Sub UnhideAll()
Dim WS As Worksheet
For Each WS In Worksheets
WS.Visible = True
Next
End Sub
Then I used Call UnhideAll right after Application.ScreenUpdating = False. I also used CurrWorkBook.Close savechanges:=False at the end so that the workbook being copied would not be saved and its hidden worksheets would go back to being hidden.
Related
I want to combine two csv into one new csv file via a vba macro but have problems accessing the values of the two files.
I can open the first file with Workbooks.Open() but I can not access any of its values by File1.ActiveSheet.Cells(1,1) or File1.ActiveSheet.Range(1,1) etc.
The catch is, that I have to open the second file through a path that is contained in the first file.
The Files look like this:
File1
File2
For every ID in File1 there is one File2 with about ~30000-60000 entrys that need to be mapped together.
My Idea was to copy File2 into the new File and than add the ID for every row.
I can not just change the File2 and ad the ID there since I have no writting rights to the Folder they are in.
The Struktur the Files are in at the Moment:
WorkingDir |
|___File1
|___Macro
|___allFile2
.........|__File2_1
.........|__File2_2
Is there a better approach to this?
I am new to vba programming and have almost no practise in it i would be really greatful if someone can help me or has some literatur that could help.
I would create another worksheet that can be used a medium for importation. What you would be doing is creating a macro that enables you to select another file from a open file window and then another macro that will copy and paste the desired data range. If you want to create a macro that integrates it into the other file you could do that as well.
Here is an example of how you might structure the File Select code:
Sub GetFile()
'Dim the variables
Dim FileSelect As Variant
Dim wb As Workbook
Dim i As Integer
'on error statement
On Error GoTo errHandler:
'hold in memory
Application.ScreenUpdating = False
'locate the file path
FileSelect = Application.GetOpenFilename(filefilter:="Excel Files,*.xl*", _
MultiSelect:=False)
'check if a file is selected
If FileSelect = False Then
MsgBox "Select the file name"
Exit Sub
End If
'send the path to the worksheet
Sheet8.Range("C4").Value = FileSelect
'open the workbook
Set wb = Workbooks.Open(FileSelect)
'add the sheet names to the workbook
'close the workbook
wb.Close False
Application.ScreenUpdating = True
Exit Sub
This would be an example of your importation code:
Public Sub GetRange()
'Dim variables
Dim FileSelect As Variant
Dim wb As Workbook
Dim Addme As Range, _
CopyData As Range, _
Bk As Range, _
Sh As Range, _
St As Range, _
Fn As Range, _
Tb As Range, _
c As Range
'on error statement
On Error GoTo errHandler:
'hold values in memory
Application.ScreenUpdating = False
'check neccessary cells have values
For Each c In Sheet8.Range("C4,F4,G4,H4")
If c.Value = "" Then
MsgBox "You have left out a value that is needed in " & c.Address
Exit Sub
End If
Next c
'set the range reference variables
Set Bk = Sheet8.Range("C4") 'file path of book to import from
Set Sh = Sheet8.Range("G4") 'Worksheet to import
Set St = Sheet8.Range("G4") 'starting cell reference
Set Fn = Sheet8.Range("H4") 'finishing cell reference
'set the destination
Set Addme = Sheet8.Range("C" & Rows.Count).End(xlUp).Offset(1, 0)
'open the workbook
Set wb = Workbooks.Open(Bk)
'set the copy range
Set CopyData = Worksheets(Sh.Value).Range(St & ":" & Fn)
'copy and paste the data
CopyData.Copy
Addme.PasteSpecial xlPasteValues
'clear the clipboard
Application.CutCopyMode = False
'close the workbook
wb.Close False
'return to the interface sheet
Sheet8.Select
End With
Application.ScreenUpdating = True
Exit Sub
'error block
errHandler:
MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " _
& Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Please notify the administrator"
End Sub
This is merely an example of how you would structure it generally. You would need to build the excel worksheet for the references needed for the variables listed in the code.
A great resource for this subject is found at this website: http://www.onlinepclearning.com/import-data-into-excel-vba/
Hope this helps!
I have built this code which import data from a workbook and paste it to another one. The original workbook is composed by hundred of sheets (one sheet for each country, identified by the ISO 2 digit code: AE, AL, AM, AR etc...). The macro is opening each one of these sheets, copying the same cell, and printing all these cells in a new workbook.
The problem is that if, for example, the sheet F(AM) doesn't exists, the macro stops. I would like to make sure that if a sheet doesn't exist, the macro continues with all the other sheets (namely F(AR), F(AT), F(AU)) till the end.
Someone has any suggestion?
Many thanks in advance!
Sub ImportData()
Dim Wb1 As Workbook
Dim MainBook As Workbook
Dim Path As String
Dim SheetName As String
'Specify input data
Path = Worksheets("Input").Range("C6").Value
'Decide in which target sheet print the results
SheetName = "Data"
'From which sheets you need to take the data?
OriginSheet145 = "F(AE)"
OriginSheet146 = "F(AL)"
OriginSheet147 = "F(AM)"
OriginSheet148 = "F(AR)"
OriginSheet149 = "F(AT)"
OriginSheet150 = "F(AU)"
'Set the origin workbook
Set Wb1 = Workbooks.Open(Path & "_20171231.xlsx")
'Set the target workbook
Set MainBook = ThisWorkbook
'Vlookup to identify the correct data point
Wb1.Sheets(OriginSheet145).Range("N25").FormulaR1C1 = "=VLOOKUP(""010"",C[-10]:C[-7],2,FALSE)"
Wb1.Sheets(OriginSheet146).Range("N26").FormulaR1C1 = "=VLOOKUP(""010"",C[-10]:C[-7],2,FALSE)"
Wb1.Sheets(OriginSheet147).Range("N27").FormulaR1C1 = "=VLOOKUP(""010"",C[-10]:C[-7],2,FALSE)"
Wb1.Sheets(OriginSheet148).Range("N28").FormulaR1C1 = "=VLOOKUP(""010"",C[-10]:C[-7],2,FALSE)"
Wb1.Sheets(OriginSheet149).Range("N29").FormulaR1C1 = "=VLOOKUP(""010"",C[-10]:C[-7],2,FALSE)"
Wb1.Sheets(OriginSheet150).Range("N30").FormulaR1C1 = "=VLOOKUP(""010"",C[-10]:C[-7],2,FALSE)"
'Copy the data point and paste in the target sheet
Wb1.Sheets(OriginSheet145).Range("N25").Copy
MainBook.Sheets(SheetName).Range("AW5").PasteSpecial xlPasteValues
Wb1.Sheets(OriginSheet146).Range("N26").Copy
MainBook.Sheets(SheetName).Range("AW6").PasteSpecial xlPasteValues
Wb1.Sheets(OriginSheet147).Range("N27").Copy
MainBook.Sheets(SheetName).Range("AW7").PasteSpecial xlPasteValues
Wb1.Sheets(OriginSheet148).Range("N28").Copy
MainBook.Sheets(SheetName).Range("AW8").PasteSpecial xlPasteValues
Wb1.Sheets(OriginSheet149).Range("N29").Copy
MainBook.Sheets(SheetName).Range("AW9").PasteSpecial xlPasteValues
Wb1.Sheets(OriginSheet150).Range("N30").Copy
MainBook.Save
Wb1.Close savechanges:=False
MsgBox "Data: imported!"
End Sub
This function returns TRUE or FALSE, indicating whether a worksheet named in string wsName exists in workbook object
Function wsExists(wb As Workbook, wsName As String) As Boolean
Dim ws: For Each ws In wb.Sheets
wsExists = (wsName = ws.Name): If wsExists Then Exit For
Next ws
End Function
Us an IF statement to skip the applicable code if the worksheet does not exist.
Edit:
I can tell that you put a lot of work into your code, which is awesome, so don't take it the wrong way when I say it gave me anxiety so I had to simplify it. ...there are a lot of unneeded steps.
I do believe the "right way" is "whatever way works", so kudo's on getting this far. There's a steep learning curve in programming, so I figured I'd offer an alternate code block to replace yours. (The Option Explicit goes at the very top of the module, and will "force" you to properly declare/handle variables, objects, etc.)
Without seeing your data I can't guarantee this will work - in fact it very likely a cell reference wrong somewhere that you'll have to try to figure out - if you choose to use this at all.
Option Explicit
Sub ImportData()
Const SheetName = "Data" 'destination sheet name
Const sourceFile = "_20171231.xlsx" 'source filename for some reason
Dim wbSrc As Workbook, wbDest As Workbook, sht As Variant
Dim stPath As String, arrSourceSht() As Variant, inRow As Long
Set wbDest = ThisWorkbook 'dest wb object
stPath = Worksheets("Input").Range("C6").Value 'source wb stPath
'create array of source sheet names "146-150":
arrSourceSht = Array("F(AE)", "F(AL)", "F(AM)", "F(AR)", "F(AT)", "F(AU)")
Set wbSrc = Workbooks.Open(stPath & sourceFile) 'open source wb
With wbSrc
'VLookup to identify the correct data point
inRow = 5 'current input row
For Each sht In arrSourceSht
If wsExists(wbSrc, CStr(sht)) Then
wbDest.Sheets(sht).Range("AW" & inRow) = Application._
WorksheetFunction.VLookup("010", Range(.Sheets(sht).Range("N" & _
20 + inRow).Offset(-10), .Sheets(sht).Range("N" & 20 + inRow).Offset(-7)), 2, False)
End If
inRow = inRow + 1 'new input row
Next sht
wbDest.Save 'save dest
.Close savechanges:=False 'don't save source
End With
MsgBox "Data: imported!"
End Sub
Function wsExists(wb As Workbook, wsName As String) As Boolean
Dim ws: For Each ws In wb.Sheets
wsExists = (wsName = ws.Name): If wsExists Then Exit For
Next ws
End Function
Let me know if you have any questions, I can walk you through how it works if you like. (I'm on here at least once a day.)
I tried to read up a few related posts on the forum but wasnt able to make a code work or understand the syntax of a few functions.
I will try to describe what I want to be done in a crisp fashion:
I have a workbook with the multiple sheets (Sheet1, Sheet2 ... Sheet 5) and I want to create a macro assigned button to Save as a new work book containing only Sheet 1, Sheet 2 and Sheet3
The file format should be Microsoft Excel 97-2003 Worksheet (.xls)
On clicking the Macro assigned button the Save as dialogue box should pop up allowing the user to select destination and also optionally a new file name (pre assigned file name can be "textstring123"
After the workbook is saved the workbook should open for user to inspect while the old workbook is minimised
I am using Excel 2013, in case that is relevant.
The post may seem crude but I have no choice but to seek help from you as I have been breaking my head over this for the last day and a half and without this the rest of my macro project will become a waste. Thank you in advance for and suggestion/advice/ help.
If any other details or clarification is required please do ask.
I have added my lines of code that I have made but doesnt seem to work properly.
Sub Macro6()
'
' Macro6 Macro
' Save as
''
Dim varResult As Variant
Sheets(Array("sheet1", "sheet2", "sheet3")).Copy
varResult = Application.GetSaveAsFilename(FileFilter:= _
"Excel Files *.xls", FileFormat:=-57, Title:="Save File", _
InitialFileName:=ActiveWorkbook.Path \ Textstring123.xls)
If varResult <> False Then
ActiveWorkbook.SaveAs Filename:=varResult, _
FileFormat:=xlWorkbookNormal
Exit Sub
End If
End Sub
This will do the trick, I have an issue with the Filters so I added a bit of error handling!
Option Explicit
Sub Macro6()
'
' Macro6 Macro
' Save as
''
Dim tB As Excel.Workbook
Dim wB As Excel.Workbook
Dim ExportArray As Variant
Dim ShName As Variant
Dim ExportName As String
Dim varResult As Variant
Set tB = ThisWorkbook
ExportArray = Array("sheet1", "sheet2", "sheet3")
For Each ShName In ExportArray
Debug.Print ShName
tB.Sheets(ShName).Copy
Set wB = ActiveWorkbook
On Error Resume Next
ExportName = Application.GetSaveAsFilename(tB.Path & "\Textstring123", "Excel Files *.xls", , "Save " & ShName)
If Err.Number > 0 Then
ExportName = Application.GetSaveAsFilename(tB.Path & "\Textstring123", , , "Save " & ShName)
Else
'No error, everything went well with filters
End If
On Error GoTo 0
'String 8 and Boolean 11
If VarType(ExportName) <> 8 Then
Exit Sub
Else
wB.SaveAs Filename:=ExportName, FileFormat:=xlWorkbookNormal
End If
DoEvents
wB.Close
Next ShName
End Sub
I have a macro that selects worksheets to be printed from worksheets that carry a value in cell A1.
I am trying to adjust the code so that it will print the pdf file with a predetermined name, eg "Output.pdf" and into the folder that the excel file is currently saved
I do not have the VBA skills to do it - I have been trying to find code in various forums, without luck.
My code currently is:
Sub Print_All_Worksheets_With_Value_In_A1()
Dim Sh As Worksheet
Dim Arr() As String
Dim N As Integer
N = 0
Application.ActivePrinter = "Adobe PDF on Ne07:"
For Each Sh In ActiveWorkbook.Worksheets
If Sh.Visible = xlSheetVisible And Sh.Range("A1").Value <> "" Then
N = N + 1
ReDim Preserve Arr(1 To N)
Arr(N) = Sh.Name
End If
Next
With ActiveWorkbook
.Worksheets(Arr).PrintOut
End With
End Sub
Any help with refining this area i n particular will be greatly appreciated
With ActiveWorkbook
.Worksheets(Arr).PrintOut
I have a slightly different idea for how to do this.
You have created an array of worksheets with Arr variable. I think instead of this:
With ActiveWorkbook
.Worksheets(Arr).PrintOut ...
End With
Do this:
Dim path as String
'Capture the path of the current workbook
path = ActiveWorkbook.Path & "\"
'The copy method will create a NEW workbook with these sheets
ActiveWorkbook.Worksheets(arr).Copy
'The NEW workbook is now "Active", so use ActiveWorkbook and exportAsFixedFormat
ActiveWorkbook.ExportAsFixedFormat xlTypePDF, path & "output.pdf"
'Closes the temporary workbook without warning
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
I want to collect data from different files and insert it into a workbook doing something like this.
Do While THAT_DIFFERENT_FILE_SOMEWHERE_ON_MY_HDD.Cells(Rand, 1).Value <> "" And Rand < 65536
then 'I will search if the last row in my main worksheet is in this file...
End Loop
If the last row from my main worksheet is in the file, I'll quit the While Loop. If not, I'll copy everything. I'm having trouble finding the right algorithm for this.
My problem is that I don't know how to access different workbooks.
The best (and easiest) way to copy data from a workbook to another is to use the object model of Excel.
Option Explicit
Sub test()
Dim wb As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xls", _
1, "Select One File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set targetworkbook
Set wb2 = ActiveWorkbook
'For instance, copy data from a range in the first workbook to another range in the other workbook
wb2.Worksheets("Sheet2").Range("C3:D4").Value = wb.Worksheets("Sheet1").Range("A1:B2").Value
End Sub
You might like the function GetInfoFromClosedFile()
Edit: Since the above link does not seem to work anymore, I am adding alternate link 1 and alternate link 2 + code:
Private Function GetInfoFromClosedFile(ByVal wbPath As String, _
wbName As String, wsName As String, cellRef As String) As Variant
Dim arg As String
GetInfoFromClosedFile = ""
If Right(wbPath, 1) <> "" Then wbPath = wbPath & ""
If Dir(wbPath & "" & wbName) = "" Then Exit Function
arg = "'" & wbPath & "[" & wbName & "]" & _
wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
On Error Resume Next
GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function
Are you looking for the syntax to open them:
Dim wkbk As Workbook
Set wkbk = Workbooks.Open("C:\MyDirectory\mysheet.xlsx")
Then, you can use wkbk.Sheets(1).Range("3:3") (or whatever you need)
There's very little reason not to open multiple workbooks in Excel. Key lines of code are:
Application.EnableEvents = False
Application.ScreenUpdating = False
...then you won't see anything whilst the code runs, and no code will run that is associated with the opening of the second workbook. Then there are...
Application.DisplayAlerts = False
Application.Calculation = xlManual
...so as to stop you getting pop-up messages associated with the content of the second file, and to avoid any slow re-calculations. Ensure you set back to True/xlAutomatic at end of your programming
If opening the second workbook is not going to cause performance issues, you may as well do it. In fact, having the second workbook open will make it very beneficial when attempting to debug your code if some of the secondary files do not conform to the expected format
Here is some expert guidance on using multiple Excel files that gives an overview of the different methods available for referencing data
An extension question would be how to cycle through multiple files contained in the same folder. You can use the Windows folder picker using:
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .Selected.Items.Count = 1 the InputFolder = .SelectedItems(1)
End With
FName = VBA.Dir(InputFolder)
Do While FName <> ""
'''Do function here
FName = VBA.Dir()
Loop
Hopefully some of the above will be of use
I had the same question but applying the provided solutions changed the file to write in. Once I selected the new excel file, I was also writing in that file and not in my original file. My solution for this issue is below:
Sub GetData()
Dim excelapp As Application
Dim source As Workbook
Dim srcSH1 As Worksheet
Dim sh As Worksheet
Dim path As String
Dim nmr As Long
Dim i As Long
nmr = 20
Set excelapp = New Application
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
.Show
path = .SelectedItems.Item(1)
End With
Set source = excelapp.Workbooks.Open(path)
Set srcSH1 = source.Worksheets("Sheet1")
Set sh = Sheets("Sheet1")
For i = 1 To nmr
sh.Cells(i, "A").Value = srcSH1.Cells(i, "A").Value
Next i
End Sub
With excelapp a new application will be called. The with block sets the path for the external file. Finally, I set the external Workbook with source and srcSH1 as a Worksheet within the external sheet.