Hi guys I have this bunch of code:
For Each ws In ThisWorkbook.Sheets
If ws.Name = "Position calculation" Or ws.Name = "Strategies & weights" Then
Else
sheet_name = ws.Name
Sheets(sheet_name).Visible = True
ThisWorkbook.Worksheets(sheet_name).Activate
ws.Range("A2").Select
For Each c In Range("A2", "A1000")
If c.Value = "" Then
c.Activate
searched_cell = ActiveCell.Offset(-1, 0).Address
GoTo flag1
End If
Next c
Everytime when I try to run a code from a sheet called "Position calculation" I get the error saying
Run - time error '1004'
Activate method of Worksheet class failed
I cannot distinguish why the code is running from other sheets, but I have to run this script exactly from the page causing me this sort of error.
Thank you in advance for your help
I couldn't figure out why you receive the error that you complain about but it's certainly true that you wouldn't have the problem if you wouldn't ask for it (as has been pointed out to you by #Siddarth Rout in the comments above). In my analysis I found that your entire approach is a little cranked even if all Select and Activate statements are removed. Please consider the approach taken below.
Private Sub Try()
Dim Ws As Worksheet
Dim NextRow As Long
For Each Ws In ThisWorkbook.Worksheets
With Ws
If .Name <> "Position calculation" And .Name <> "Strategies & weights" Then
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
If NextRow <= 1000 Then Exit For
End If
End With
Next Ws
NextRow = WorksheetFunction.Max(NextRow, 2)
MsgBox Ws.Name & vbCr & "cell " & Cells(NextRow, "A").Address(0, 0)
End Sub
This code will return the same result whichever sheet is active and regardless of whether a sheet is hidden or visible.
Is there a way to skip error "filename is not found" and move to the next file?
Sub CopyDataAndMoveDown()
Application.ScreenUpdating = False
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.ActiveSheet
Dim rngToCopy As Range, rngToPaste As Range
Dim x As Long
Dim breakdown1
Dim breakdown As Worksheet: Set breakdown = wb.ActiveSheet
For x = 4 To 504 Step 6
With wb.Sheets("Sheet1")
breakdown1 = breakdown.Cells(9, x - 2)
End With
If IsEmpty(breakdown1) Then
Call MoveBelow
Else
With wb.Sheets("Sheet1")
Set rngToCopy = .Range(.Cells(4, x - 2), .Cells(24, x + 3))
Debug.Print rngToCopy.Address
End With
With wb.Sheets("Sheet2")
Set rngToPaste = .Range(.Cells(4, x - 2), .Cells(rngToCopy.Rows.Count + 3, x + 3))
Debug.Print rngToPaste.Address
End With
rngToPaste = rngToCopy.Value
End If
Next x
Application.ScreenUpdating = True
MsgBox "Valmis."
End Sub
Sub MoveBelow ()
Application.ScreenUpdating = False
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.ActiveSheet
Dim rngToCopy As Range, rngToPaste As Range
Dim x As Long
Dim breakdown1
Dim breakdown As Worksheet: Set breakdown = wb.ActiveSheet
For x = 4 To 504 Step 6
With wb.Sheets("Sheet1")
breakdown1 = breakdown.Cells(9, x - 2)
End With
If IsEmpty(breakdown1) Then
' At this point when the macro meet again a empty cell
' it should keep moving from the same counted X
' but start the paste operation from 24 rows below.
Else
With wb.Sheets("Sheet1")
Set rngToCopy = .Range(.Cells(4, x - 2), .Cells(24, x + 3))
Debug.Print rngToCopy.Address
End With
With wb.Sheets("Sheet2")
Set rngToPaste = .Range(.Cells(28, x - 2), .Cells(rngToCopy.Rows.Count + 3, x + 3))
Debug.Print rngToPaste.Address
End With
rngToPaste = rngToCopy.Value
End If
Next x
Application.ScreenUpdating = True
MsgBox "Valmis."
End Sub
So when the macro is copying / pasting data from Sheet 1 to Sheet 2 and meets an empty cell it should keep going, copying next available data, but paste it 24 rows below.
--------Below the old question.
I have a VBA which is opening and closing file for that INDEX function get data. My problem is that. VBA is getting the filename from reference cell which contain the full path. But some of the reference cells are blanks/zeros and then the running VBA stops and give me error "filename is not found". Is there a way to skip that and move to next step?
Sub HaeReseptiTiedot()
Dim myfile As String
Dim myfile1 As String
Dim myfile2 As String
Dim myfile3 As String
Dim myfile4 As String
Dim myfile5 As String
Dim myfile6 As String
Dim myfile7 As String
Dim myfile8 As String
Dim myfile9 As String
myfile = Cells(19, 4).Value
myfile1 = Cells(19, 9).Value
myfile2 = Cells(19, 14).Value
myfile3 = Cells(19, 19).Value
myfile4 = Cells(19, 24).Value
myfile5 = Cells(19, 29).Value
myfile6 = Cells(19, 34).Value
myfile7 = Cells(19, 39).Value
myfile8 = Cells(19, 44).Value
myfile9 = Cells(19, 49).Value
Application.ScreenUpdating = False
Workbooks.Open Filename:=myfile, UpdateLinks:=0
ActiveWorkbook.Close False
Sheets("Aputaulukko 2").Select
Range("D16:G30").Select
Selection.Copy
Sheets("Aputaulukko 3").Select
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks.Open Filename:=myfile1, UpdateLinks:=0
ActiveWorkbook.Close False
Sheets("Aputaulukko 2").Select
Range("I16:L30").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Aputaulukko 3").Select
Range("G4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
The best way I have found to handle this is to use the "On Error" statement. You can keep it really simple and use On Error Resume Next, which tells the code to skip the error entirely and move to the next statement (that does not have an error). The main issue with this is that it covers ALL errors, not just the specific one you are having issues with currently. It can make it hard to know if errors are occurring/if your code is functioning as you expect.
The other option, which can help avoid the issues mentioned above, is to use something like this:
On Error GoTo ErrH
'Main Body of Your Code
Exit Sub 'Use to avoid continuing on to the ErrH section.
ErrH:
'Some method for handling the error, such as a message box or other notification.
This usually isn't necessary with small chunks of code, but when you start combining your subs and functions it can be a life saver!
Good Luck!
Edit: You could/should also consider removing those blanks if they are not necessary for the sheet to work.
Here is a function that can check if a file exists:
'********************************************************************************************************************************
' To check if a particular file exists
' Set excelFile = False, if it is not an Excel file that is being checked
'********************************************************************************************************************************
Public Function isAnExistingFile(ByVal fileNameStr As Variant, Optional ByVal excelFile As Boolean = True) As Boolean
Dim wb As Workbook
isAnExistingFile = True
Err.Clear
On Error GoTo errHandler
If Not VarType(fileNameStr) = vbString Then
isAnExistingFile = False
ElseIf Len(fileNameStr) = 0 Then
isAnExistingFile = False
ElseIf Len(Dir(fileNameStr)) = 0 Then
isAnExistingFile = False
ElseIf ((GetAttr(fileNameStr) And vbDirectory) <> vbDirectory) = False Then
isAnExistingFile = False
Else
If excelFile Then
On Error Resume Next
Set wb = Application.Workbooks.Open(Filename:=fileNameStr, UpdateLinks:=0, ReadOnly:=True)
If wb Is Nothing Then isAnExistingFile = False
If Not wb Is Nothing Then
wb.Close False
Set wb = Nothing
End If
GoTo Out
End If
End If
errHandler:
If Not Err.Number = 0 Then isAnExistingFile = False
Out:
Err.Clear: On Error GoTo 0
End Function
I took the liberty to rewrite your code... i'm still not quite sure why you are openning and closing the workbook immediately, but in essence this is what your code does at the moment:
Option Explicit
Sub HaeReseptiTiedot()
Application.ScreenUpdating = False
Dim wbSource As Workbook
Dim wb As Workbook: Set wb = ThisWorkbook 'Or ActiveWorkbook or Workbooks("book name")
Dim ws As Worksheet: Set ws = wb.ActiveSheet 'Or wb.Sheets("Sheet Name")
Dim rngToCopy As Range, rngToPaste As Range
Dim X As Long
For X = 4 To 49 Step 5
On Error Resume Next
Set wbSource = Workbooks.Open(FileName:=ws.Cells(19, X), UpdateLinks:=0)
On Error GoTo 0
If Not wbSource Is Nothing Then
wbSource.Close False
With wb.Sheets("Aputaulukko 2")
Set rngToCopy = .Range(.Cells(16, X), .Cells(30, X + 3))
'Debug.Print rngToCopy.Address
End With
With wb.Sheets("Aputaulukko 3")
Set rngToPaste = .Range(.Cells(4, X - 2), .Cells(rngToCopy.Rows.Count + 3, X + 1))
'Debug.Print rngToPaste.Address
End With
rngToPaste = rngToCopy.Value
End If
Set wbSource = Nothing
Next X
Application.ScreenUpdating = True
End Sub
You could work around this by creating a second Sub that opens the file and handles the error if the file doesn't exist. That way you are still able to catch other Errors in the main Sub without going to next. Example:
Sub MainSub()
myFile1 = "C:\Temp\New1.xlsx"
myFile2 = "C:\Temp\New2.xlsx"
CheckAndOpen (myFile1)
CheckAndOpen (myFile2)
End Sub
Sub CheckAndOpen(myFileName As String)
On Error Resume Next
Workbooks.Open Filename:=myFileName
Debug.Print Err.Number, myFileName
End Sub
You could, alternatively, just put the following in your code:
If dir("FILENAME") <> "" Then
Add the rest of your code
End If
I usually run 3 or 4 for loops inside of each other with different variables to get the full path of each file, then put this to ensure I do not open files where there are blanks.
I have a problem when I create macro in one workbook that use another workbook.
This is the code that I am using :
Private Sub CommandButton21_Click()
Set wb1 = Workbooks.Open("
http://europort/it_division/ITAC/Portal/Documentations/Proba 1.xlsx"
)
With wb1
FinalRow = .Worksheets("Sheet1")
.Cells(.Worksheets("Sheet1").Rows.Count, 1)
.End(xlUp).Row
For i = 1 To FinalRow
If TextBox21.Text = .Worksheets("Sheet1").Cells(i, 1).Value Then
MsgBox .Worksheets("Sheet1").Cells(i, 2).Text
Next i
End With
wb1.Close
End Sub
It's working fine but it opens another workbook and only when I click OK button it closes that workbook. I don't want to open this workbook, only to see result and not to see entire excel workbook. How can I do that? Please help.
This should do what you're after, based on your question:
Private Sub CommandButton21_Click()
Application.ScreenUpdating = False
msg = ""
Set wb1 = Workbooks.Open("http://europort/it_division/ITAC/Portal/Documentations/Proba 1.xlsx")
With wb1
FinalRow = .Worksheets("Sheet1").Cells(.Worksheets("Sheet1").Rows.Count, 1).End(xlUp).Row
For i = 1 To FinalRow
If TextBox21.Text = .Worksheets("Sheet1").Cells(i, 1).Value Then
msg = msg & .Worksheets("Sheet1").Cells(i, 2).Text & vbCr
Next i
End With
wb1.Close
Application.ScreenUpdating = True
If msg <> "" Then MsgBox msg
End Sub
The whole thing needs tidying up, you should declare etc. but as it stands now if your code works this should also work.
I am new to VBA in excel and I ran into an error that I am unsure how to interpret. I was wondering if somebody could help. I am trying to create s table of contents for an excel file and I found a macro online. It is posted below:
Sub Create_TOC()
Dim wbBook As Workbook
Dim wsActive As Worksheet
Dim wsSheet As Worksheet
Dim lnRow As Long
Dim lnPages As Long
Dim lnCount As Long
Set wbBook = ActiveWorkbook
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
'If the TOC sheet already exist delete it and add a new
'worksheet.
On Error Resume Next
With wbBook
.Worksheets(“TOC”).Delete
.Worksheets.Add Before:=.Worksheets(1)
End With
On Error GoTo 0
Set wsActive = wbBook.ActiveSheet
With wsActive
.Name = “TOC”
With .Range(“A1:B1”)
.Value = VBA.Array(“Table of Contents”, “Sheet # – # of Pages”)
.Font.Bold = True
End With
End With
lnRow = 2
lnCount = 1
‘Iterate through the worksheets in the workbook and create
‘sheetnames, add hyperlink and count & write the running number
‘of pages to be printed for each sheet on the TOC sheet.
For Each wsSheet In wbBook.Worksheets
If wsSheet.Name <> wsActive.Name Then
wsSheet.Activate
With wsActive
.Hyperlinks.Add .Cells(lnRow, 1), “”, _
SubAddress:=”‘” & wsSheet.Name & “‘!A1”, _
TextToDisplay:=wsSheet.Name
lnPages = wsSheet.PageSetup.Pages().Count
.Cells(lnRow, 2).Value = “‘” & lnCount & “ - ” & lnPages
End With
lnRow = lnRow + 1
lnCount = lnCount + 1
End If
Next wsSheet
wsActive.Activate
wsActive.Columns(“A:B”).EntireColumn.AutoFit
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
The error which I received was this:
Compile Error: Variable TOS not defined.
I am really new to this and I am unsure about what this means. Could somebody provide a detailed explanation on what the problem is and how to go about fixing it.
I believe the problem is in the quotation marks, there are angled/curly brackets being used and this is stopping the code being read properly.
Taking the first instance of the issue: -
.Worksheets(“TOC”).Delete
You receive the error:-
Compile Error:
Variable not defined
and “TOC” is highlighted. This is occurring because the wrong quotation marks are being so TOC is not being seen as a literal string but instead “TOC” is being presumed to be a variable, that is not defined (i.e. does not exist).
This can be fixed by going through your code and replacing all the below: -
Change “ (Angled open quotation) to " (straight quotation (shift+2)
Change ” (Angled close quotation) to " (straight quotation (shift+2)
Change ‘ (Angled apostrophe) to ' (straight single quotation (', shares the # key)
The following macro works fine without the 1st and 3rd lines emphasised (i.e. password protection). When I add the code the macro works the first time but if I open the file again, it returns a run time error 'pastespecial method of range class failed' at the line second line emphasised. The purpose of the macro is to open a purchase order template, increment the purchase order number by one, complete a second log file with date, purchase order number and user name and re-save the purchase order template under a different file name:
Private Sub Workbook_Open()
If ThisWorkbook.ReadOnly Then
MsgBox "Please use dropdown arrow next to filename within SharePoint and select 'Edit in Microsoft Office Excel' instead."
ThisWorkbook.Close
End If
Range("L14") = Range("L14") + 1
ActiveWorkbook.Save
Range("L14").Copy
Workbooks.Open Filename:="\\ehfnp01\users\gminter\My Documents\PO Log Elite\PO Log Elite.xls"
Workbooks("PO Log Elite.xls").Activate
Dim lst As Long
With ActiveWorkbook.Sheets("Sheet1")
*.Unprotect Password:="2"*
lst = .Range("B" & Rows.Count).End(xlUp).Row + 1
**.Range("B" & lst).PasteSpecial xlPasteValuesAndNumberFormats**
End With
With ActiveWorkbook.Sheets("Sheet1")
lst = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & lst) = Now
End With
With ActiveWorkbook.Sheets("Sheet1")
lst = .Range("C" & Rows.Count).End(xlUp).Row + 1
.Range("C" & lst).Value = Environ("Username")
*.Protect Password:="2"*
End With
ActiveWorkbook.Save
ActiveWorkbook.Close
ThisFile = Application.DefaultFilePath & "\" & Range("G14").Value & Range("L14").Text
ActiveWorkbook.SaveAs Filename:=ThisFile
Range("L15") = Now
Range("E20").Value = Environ("Username")
ScreenUpdating = False
Set Rng = Intersect(ActiveSheet.UsedRange, Range("e20"))
For Each C In Rng
C.Value = StrConv(C.Value, vbUpperCase)
Next
ScreenUpdating = True
Cells.Locked = False
Range("G14:N15,E20:N20").Locked = True
ActiveSheet.Protect Password:="1"
Dim x As Integer
On Error Resume Next
With ActiveWorkbook.VBProject
For x = .VBComponents.Count To 1 Step -1
.VBComponents.Remove .VBComponents(x)
Next x
For x = .VBComponents.Count To 1 Step -1
.VBComponents(x).CodeModule.DeleteLines _
1, .VBComponents(x).CodeModule.CountOfLines
Next x
End With
On Error GoTo 0
End Sub
Any help would be greatly appreciated as I can't find any similar examples of this.
What happens when you explicitly declare your Objects/Variables and then work with them? That ways you do the copy just before you paste. This will ensure that the clipboard doesn't get cleared for any reason which Excel is unfortunately famous for...
Private Sub Workbook_Open()
Dim rng As Range
Dim newWb As Workbook, wb As Workbook
Dim lst As Long
If ThisWorkbook.ReadOnly Then
MsgBox "Please use dropdown arrow next to filename within SharePoint and select 'Edit in Microsoft Office Excel' instead."
ThisWorkbook.Close
Exit Sub '<~~ ?
End If
Set rng = ThisWorkbook.Sheets("Sheet1").Range("L14")
rng.Value = rng.Value + 1
ThisWorkbook.Save
Set newWb = Workbooks.Open(Filename:="\\ehfnp01\users\gminter\My Documents\PO Log Elite\PO Log Elite.xls")
Set wb = Workbooks("PO Log Elite.xls")
With wb.Sheets("Sheet1")
.Unprotect Password:="2"
lst = .Range("B" & .Rows.Count).End(xlUp).Row + 1
rng.Copy '<~~ Do the copy here
.Range("B" & lst).PasteSpecial xlPasteValuesAndNumberFormats
End With
'
'~~> Rest of the code
'
End Sub