When I tried to get excel to choose which workbook to use, it gives me an error for subscript out of range. I don't know whether I have to reference which folder it originates from. They are all in the same folder. I looked through other peoples solutions,but I don't have neither the same format nor task. The error is on the line where it assigns workbook numbers
Sub bringbookstogether()
Dim currentsheet As Worksheet
Set currentsheet = Application.ActiveSheet
Dim othersheets As Worksheet
Dim wbook As Workbook
Dim c As String
'assigns the number to start with
Dim a, b, d As Integer
a = 4
b = 6
d = 1
'assigns workbook numbers
If (d = 1) Then
Set wbook = Workbooks("MaintPrep Sheet 1st")
Else
If (d = 2) Then
Set wbook = Workbooks("MaintPrep Sheet 2nd")
Else
If (d = 3) Then
Set wbook = Workbooks("MaintPrep Sheet 3rd")
End If
End If
End If
'End if it's done with all the workbooks
Do Until (d = 4)
'Looks for the sheet that has the same name
Do While (c = currentsheet.Name)
'Ends in row 99
Do While (b < 99)
'Ends in Column 52
Do While (a < 52)
currentsheet.Cells(b, a) = currentsheet.Cells(b, a) + Workbooks(d).Sheets(c).Cells(b, a)
a = a + 1
Loop
b = b + 1
Loop
Loop
d = d + 1
Loop
End Sub
First of all, it's better to use the full filename:
Workbooks("MaintPrep Sheet 1st.xlsx") etc.
Second of all, this code will error as soon as one of the Workbooks you're trying to access is not currently opened. If a Workbook is not open, it doesn't exist within the current context and thus Excel will throw error 91.
To fix this, you could do:
Sub a()
Dim wb As Workbook
On Error Resume Next 'To avoid error 91
Set wb = Workbooks("MaintPrep Sheet 1st.xlsx")
On Error GoTo 0 'To avoid not seeing other errors.
If Not wb Is Nothing Then
'Do stuff
MsgBox "Opened!"
Else
'Handle the fact that it's missing
MsgBox "Not open!"
End If
'Alternatively, OPEN the workbook if you couldn't set it in the first place:
On Error Resume Next
Set wb = Workbooks("MaintPrep Sheet 1st.xlsx")
On Error GoTo 0
If wb Is Nothing Then
Set wb = Workbooks.Open("C:\FullPath\MaintPrep Sheet 1st.xlsx")
'Do stuff
End If
End Sub
Related
I have a workbook (A) in which I have one module with one subroutine. The subroutine downloads an excel file (workbook(B)) from the internet and opens it. The problem I'm faced with is finding a way to execute a subroutine in workbook (B) from the sub in workbook (A).
To reiterate, I have my desired subroutine only in workbook (A) and wish to apply it to workbook (B) by use of the sub in workbook (A).
Note: In my code workbook (B) = Nuance Mobility JIRA.xls and the desired subroutine in workbook (B) that needs to be executed is removeColumns().
My code can be found below :
Public Sub DL()
Dim WebUrl As String
Dim x As Workbook
Dim z As Workbook
Dim nmjexcel As String
Dim xlApp As Excel.Application
' I check to see if the file exists and delete it if it does
nmjexcel = "C:\Users\" & [A2] & "\Downloads\Nuance Mobility JIRA.xls"
If Len(Dir(nmjexcel)) <> 0 Then
SetAttr nmjexcel, vbNormal
Kill nmjexcel
End If
'I open chrome and download the file from an URL
WebUrl = [J1]
Shell ("C:\Program Files (x86)\Google\Chrome\Application\chrome.exe -url " & WebUrl)
Application.Wait (Now + TimeValue("0:00:3"))
'I create a new 'hidden' excel app and open workbook (B)
Set xlApp = New Excel.Application
xlApp.Visible = False
Set x = Workbooks.Open("C:\Users\" & [A2] & "\Downloads\Nuance Mobility JIRA.xls")
' I delete some rows, a picture and some columns.
' It's here that i would like my other subroutine, removeColumns(), to take place !
With x.Sheets("general_report")
.Rows("1:3").Delete
.Shapes.Range(Array("Picture 1")).Delete
.Cells.UnMerge
.Range("A:A,D:D,E:E,F:F,H:H,I:I,J:J,K:K,L:L,M:M,N:N,O:O,P:P").Delete Shift:=xlToLeft
End With
'Then I copy whats left and paste it into workbook (A)
Set z = ThisWorkbook
Application.ScreenUpdating = False
x.Sheets("general_report").Range("A1").CurrentRegion.Copy
z.Sheets(1).Range("A13").PasteSpecial xlValues
x.Save
x.Application.CutCopyMode = False
x.Close
End Sub
My desired sub to be executed is the following
Sub removeColumns()
Dim rng As Range 'store the range you want to delete
Dim c 'total count of columns
Dim I 'an index
Dim j 'another index
Dim headName As String 'The text on the header
Dim Status As String 'This vars is just to get the code cleaner
Dim Name As String
Dim Age As String
Dim sht As Worksheet
Rows("1:3").Delete
Key = "Key"
Summary = "Summary"
Status = "Status"
Set sht = Sheets("general_report")
sht.Activate 'all the work in the sheet "Incidents"
c = Range("A1").End(xlToRight).Column
'From A1 to the left at the end, and then store the number
'of the column, that is, the last column
j = 0 'initialize the var
For I = 1 To c 'all the numbers (heres is the columns) from 1 to c
headName = Cells(1, I).Value
If (headName <> Key) And (headName <> Summary) And (headName <> Status) Then
'if the header of the column is differente of any of the options
j = j + 1 ' ini the counter
If j = 1 Then 'if is the first then
Set rng = Columns(I)
Else
Set rng = Union(rng, Columns(I))
End If
End If
Next I
rng.Delete 'then brutally erased from leaf
End Sub
Thank you very much in advance !
Further questions :
1) Is there a way to keep the downloaded excel hidden ?
I have :
Set xlApp = New Excel.Application
xlApp.Visible = False
Set x = Workbooks.Open("C:\Users\" & [A2] & "\Downloads\Nuance Mobility JIRA.xls")
But if i use x= xlApp.Workbooks.Open it gives me an error 'subscript out of range' and highlights :
Set sht = Sheets("general_report")
I tried doing
Dim xlApp as Excel.Application)
...
Set sht = xlApp.Sheets("general_report")
But it gets more errors
2) More generally, is their a way to keep the focus on my workbook (A), so that when chrome downloads the workbook (B) the chrome window doesn't pop up in front ?
The problem you are facing, occurs because you dont directly address the needed worksheet/workbook, you rather always use the Selected worksheet, which you shouldn´t. It´s unclear and can be done just as simple if directly referring.
To refer to the worbookB I added a parameter to the sub removeColumns, so you can pass the needed workbook.
In the sub then, you just need to use the reference wherever you are working with the worksheet.
So instead of just writing:
somVariable = Cells(1,1).Value 'This always refers to the 'Selected' worksheet
You have to write:
someVariable = myWorkbook.myWorksheet.Cells(1,1).Value
'or to use the parameter wb like i did in your code:
someVariable = wb.Sheets(1).Cells(1,1).Value
'Here the first sheet of this workbook will be used
'You also can use the 'With' statment here:
With wb.Sheets(1)
someVariable = .Cells(1,1).Value 'Note the dot in font of the 'Cells'
End With
So to use this knowledge in you example, you should try to alter code like following:
/////////////////////////////////////////////////////////////////////////
Set xlApp = New Excel.Application
xlApp.Visible = False
xlApp.Workbooks.Open("C:\Users\" & [A2] & "\Downloads\Nuance Mobility JIRA.xls")
Set x = xlApp.Workbooks(1)
Call removeColumns(x)
/////////////////////////////////////////////////////////////////////////
Sub removeColumns(ByVal wb As Workbok)
...
'Always when you are referring to the workbook, you have to use the reference passed as parameter
wb.Sheets("general_report").Rows("1:3").Delete
'In you code the first three rows will always be deleted from the 'Selected' sheet and not the one you are working on later, the 'general_report'
...
Set sht = wb.Sheets("general_report")
'Also don´t activate() sheet here, youst directly refer to it later
'sht.Activate 'all the work in the sheet "Incidents"
'You can directly refer t it over the variable you created, like this:
c = sht.Range("A1").End(xlToRight).Column
'From A1 to the left at the end, and then store the number
'of the column, that is, the last column
j = 0 'initialize the var
For I = 1 To c 'all the numbers (heres is the columns) from 1 to c
headName = sht.Cells(1, I).Value
If (headName <> Key) And (headName <> Summary) And (headName <> Status) Then
'if the header of the column is differente of any of the options
j = j + 1 ' ini the counter
If j = 1 Then 'if is the first then
Set rng = sht.Columns(I)
Else
Set rng = Union(rng, sht.Columns(I))
End If
End If
Next I
rng.Delete 'then brutally erased from leaf
End Sub
Hope I could help and if something is still unclear feel free to ask.
I keep having this issue of VBA either not having an object for the new sheet I want to merge, or having the subscript out of range issue come up. None of the things I tried ended up working.
Private Sub MergeButton_Click()
Dim filename As Variant
Dim wb As Workbook
Dim s As Sheet1
Dim thisSheet As Sheet1
Dim lastUsedRow As Range
Dim j As Integer
On Error GoTo ErrMsg
Application.ScreenUpdating = False
Set thisSheet = ThisWorkbook.ActiveSheet
MsgBox "Reached method"
'j is for the sheet number which needs to be created in 2,3,5,12,16
For Each Sheet In ActiveWorkbook.Sheets
For i = 0 To FilesListBox.ListCount - 1
filename = FilesListBox.List(i, 0)
'Open the spreadsheet in ReadOnly mode
Set wb = Application.Workbooks.Open(filename, ReadOnly:=True)
'Copy the used range (i.e. cells with data) from the opened spreadsheet
If FirstRowHeadersCheckBox.Value And i > 0 Then 'Only include headers from the first spreadsheet
Dim mr As Integer
mr = wb.ActiveSheet.UsedRange.Rows.Count
wb.ActiveSheet.UsedRange.Offset(3, 0).Resize(mr - 3).Copy
Else
wb.ActiveSheet.UsedRange.Copy
End If
'thisSheet = ThisWorkbook.Worksheets(SheetCurr)
'Paste after the last used cell in the master spreadsheet
If Application.Version < "12.0" Then 'Excel 2007 introduced more rows
Set lastUsedRow = thisSheet.Range("A65536").End(xlUp)
Else
Set lastUsedRow = thisSheet.Range("A1048576").End(xlUp)
End If
'Only offset by 1 if there are current rows with data in them
If thisSheet.UsedRange.Rows.Count > 1 Or Application.CountA(thisSheet.Rows(1)) Then
Set lastUsedRow = lastUsedRow.Offset(1, 0)
End If
lastUsedRow.PasteSpecial
Application.CutCopyMode = False
Next i
This is where I try to add an extra loop that copies the next sheet (which is Sheet12) but it comes up with the Subscript our of range error.
Sheets("Sheet3").Activate
Sheet.Copy After:=ThisWorkbook.Sheets
Next Sheet
It will then move to the next sheet to perform the loop again.
ThisWorkbook.Save
Set wb = Nothing
#If Mac Then
'Do nothing. Closing workbooks fails on Mac for some reason
#Else
'Close the workbooks except this one
Dim file As String
For i = 0 To FilesListBox.ListCount - 1
file = FilesListBox.List(i, 0)
file = Right(file, Len(file) - InStrRev(file, Application.PathSeparator, , 1))
Workbooks(file).Close SaveChanges:=False
Next i
#End If
Application.ScreenUpdating = True
Unload Me
ErrMsg:
If Err.Number <> 0 Then
MsgBox "There was an error. Please try again. [" & Err.Description & "]"
End If
End Sub
Any help an this would be great
Your source code is very confusing and I believe you're stumbling because the ActiveWorkbook and ActiveSheet change each time you open a new workbook. It's also not clear why you're copying/merging the data from each worksheet in every opened workbook and then copying Sheet3. You will help yourself by more clearly defining what and where your data is and how you're moving it around.
As an example (that may not solve your problem, because your problem is not clear), look at the code below to see how you can keep the sources and destinations straight within your loops. Modify this example as much as you need in order to match your exact situation.
Sub Merge()
'--- assumes that each sheet in your destination workbook matches a sheet
' in each of the source workbooks, then copies the data from each source
' sheet and merges/appends that source data to the bottom of each
' destination sheet
Dim destWB As Workbook
Dim srcWB As Workbook
Dim destSH As Worksheet
Dim srcSH As Worksheet
Dim srcRange As Range
Dim i As Long
Application.ScreenUpdating = False
Set destWB = ThisWorkbook
For i = 0 To FileListBox.ListCount - 1
Set srcWB = Workbooks.Open(CStr(FileListBox(i, 0)), ReadOnly:=True)
For Each destSH In destWB.Sheets
Set srcSH = srcWB.Sheets(destSH.Name) 'target the same named worksheet
lastdestrow = destSH.Range("A").End(xlUp)
srcSH.UsedRange.Copy destSH.Range(Cells(lastdestrow, 1))
Next destSH
srcWB.Close
Next i
Application.ScreenUpdating = True
End Sub
I have written the following Excel VBA Macro, its job is to split a report based on CountryCode. It creates a new workbook, copies the relevant rows to a new workbook, saves the workbook by the CountryCode.
The problem I encouter is missing rows and for one worksheet, it continues running on empty rows? - Basically it doesn't stop and copies over empty rows.
Has cell formatting anything to do with it?
There is another Macro that runs only once which creates the workbooks first. It is only run once on the first worksheet, never again.
Sub RUN2_ReportSplitterOptimized()
Application.DisplayAlerts = False
Application.EnableEvents = False
' Current Workbook
Dim cW As Workbook
Dim cWL As String
Dim cWN As String
Set cW = ThisWorkbook
cWL = cW.Path
cWN = cW.Name
' Current Worksheet
Dim cS As Worksheet
Set cS = ActiveSheet
Do Until IsEmpty(ActiveCell)
' Current Active Cell
Dim aC As Range
Set aC = ActiveCell
' Split input string
Dim CC As String
CC = splitCC(aC.Text)
Dim wb As Workbook
Dim ws As Worksheet
On Error Resume Next
Set wb = Workbooks(CC & ".xlsx")
If Err.Number <> 0 Then
Set wb = Workbooks.Open(cWL & "\" & CC & ".xlsx")
' Create the worksheet
Set ws = wb.Sheets.Add
' Copy the row to the worksheet
ws.Rows(1).Value = cS.Rows(1).Value
ws.Rows(2).Value = aC.EntireRow.Value
With ws
.Name = cS.Name
End With
Else
wb.Activate
On Error Resume Next
Set ws = wb.Sheets(cS.Name)
If Err.Number <> 0 Then
Set ws = wb.Sheets.Add
' Copy the row to the worksheet
ws.Rows(1).Value = cS.Rows(1).Value
ws.Rows(2).Value = aC.EntireRow.Value
With ws
.Name = cS.Name
End With
Else
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
ws.Rows(LastRow + 1).Value = aC.EntireRow.Value
End If
End If
wb.Save
cW.Activate
aC.Offset(1, 0).Select
Loop
Dim wbk As Workbook
For Each wbk In Workbooks
If Len(wbk.Name) = 7 Then
wbk.Close
End If
Next
End Sub
Function splitCC(countrycode As String) As String
If Len(countrycode) < 3 Then
splitCC = countrycode
Else
splitCC = Mid(countrycode, InStr(countrycode, "(") + 1, 2)
End If
End Function
Solved it.
I have used filters as recommended by #sous2817
Instead of running couple of hours - it does the entire job within 2 minutes :D
Thanks for your help
Problem has been solved here: Excel VBA AutoFilter adds empty rows
I am trying to select a worksheet every time when i open up a workbook using an inputbox in VBA. here is my code for opening a workbook but after i open up my workbook, how do i select a worksheet inside that workbook?
Sub button7_click()
dim wb as string
dim ss as string
wb = Application.GetOpenFilename
if wb <> "False" Then Workbooks.Open wb
End sub
Assuming "Sheet1" is the name of the sheet that you want to select...
Workbooks(wb).Sheets("Sheet1").Select
EDIT: And you can use something like this to get a variable sheet name from an InputBox. In its simplest form...
Dim Result As String
Result = InputBox("Provide a sheet name.")
Workbooks(wb).Sheets(Result).Select
...but I would add some error handling into this also to prevent errors from blanks, misspelled or invalid sheet names.
Let's say you have a "normal", blank Excel workbook with sheets "Sheet1", "Sheet2" and "Sheet3". Now, when the workbook opens, let's assume you want to activate (not select, as that's different) the sheet called "Sheet2".
In your workbook's ThisWorkbook module, add this code:
Private Sub Workbook_Open()
ActiveWorkbook.Sheets("Sheet2").Activate
End Sub
Make sure this code is pasted inside of the ThisWorkbook object and not in a Module, Form, or Sheet object.
Save and exit the workbook. When you re-open it, "Sheet2" will be the active sheet.
Here is the final code if anyone wants it.
Multiple selections are not quite possible , as the copied worksheet only copies across and increments the largest value of the range selected rather than all the cells selected individually ....
Sub CopyAndIncrement()
Dim ws As Worksheet
Dim Count As Integer
Dim Rng As Range
Dim myValue As Integer
Dim wsName As String
wsName = InputBox("Provide the EXACT sheet name you want to copy.")
'error handling loop for Worksheet name
For p = 1 To Worksheets.Count
If Worksheets(p).Name = wsName Then
exists = True
End If
Next p
If Not exists Then
While exists = False
wsName = InputBox("Sheet not found re-enter name.")
For p = 1 To Worksheets.Count
If Worksheets(p).Name = wsName Then
exists = True
End If
Next p
Wend
End If
Set Rng = Application.InputBox( _
Title:="Increment your worksheet", _
Prompt:="Select a cell(s) you want to increment", _
Type:=8)
On Error GoTo 0
If Rng Is Nothing Then Exit Sub 'Test to ensure User Did not cancel
'Set Rng = Rng.Cells(1, 1) 'Set Variable to first cell in user's input (ensuring only
'1 cell) >> commenting this can give multiple selections
myValue = InputBox("How many time do you want it to increment? Give me the number ")
Do While Count < myValue
For Each ws In Worksheets ' this loop selects the last sheet in the workbook
LastWs = ws.Name
i = ws.Range(Rng.Address).Value
If i > j Then
j = i
End If
Next
Sheets(wsName).Select
Sheets(wsName).Copy After:=Sheets(LastWs)
ActiveSheet.Range(Rng.Address).Value = j + 1
Count = Count + 1
Loop
End Sub
I have a code to List out all the open workbooks, since all my codes are in Personal.xlsb it also get listed, can anyone tell me an If condition to skip the Personal.xlsb from the list.
And also since Personal.xlsb dose not have a "Data_Index" it tends to give an error for that too
Sub ListWorkbooks()
Dim Wb As Workbook
For j = 1 To Workbooks.Count
Sheets("Data_Index").Select
Range("H3").Cells(j, 1) = Workbooks(j).Name
For i = 1 To Workbooks(j).Sheets.Count
Next i
Next j
End Sub
Sub ListWorkbooks()
Dim Wb As Workbook
Dim i As Integer, j As Integer
For j = 1 To Workbooks.Count
If Workbooks(j).Name <> ThisWorkbook.Name Then
Workbooks(j).Sheets("Data_Index").Range("H3").Cells(j, 1) = Workbooks(j).Name
End If
'not sure what you want to do here
For i = 1 To Workbooks(j).Sheets.Count
Next i
Next j
End Sub
Revised Answer
From reading your comments on other answers you need to also identify which of the open workbooks has a worksheet named Data_Index as well, which is why you were getting a subscript out of range (your code assumed that every workbook had a sheet named Data_Index.
This works for me when I test:
Sub ListWorkbooks()
Dim Wb As Workbook, wb2 As Workbook
Dim sht As Worksheet
Dim c As Range
'Identify which (if any) of the open workbooks has sheet Data_Index
'Note if more than one it will pick the last one it finds
On Error Resume Next
For j = 1 To Workbooks.Count
Set sht = Workbooks(j).Sheets("Data_Index")
Next j
On Error GoTo 0
'Check at least one has the required sheet
If sht Is Nothing Then
MsgBox "There is no open workbook with a sheet named Data_Index", vbExclamation
Else
'Set the destination for the first workbook name
Set c = sht.Range("H3")
For j = 1 To Workbooks.Count
If Workbooks(j).Name = "Personal.xlsb" Then GoTo NextWb
c.Value = Workbooks(j).Name
For i = 1 To Workbooks(j).Sheets.Count
' Whatever you want to do cycling sheets
Next i
'Offset to the next row ready for the next name
Set c = c.Offset(1, 0)
NextWb:
Next j
End If
End Sub
You could do this using arrays, but the above will do it for you.