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.
Related
I intend to rename all the sheets with the cell "G2" value except the two sheets called "Main" and "Fixed".
The code keeps renaming the two sheets.
Sub RenameSheets()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
'With ActiveWorkbook.ActiveSheet
If ActiveWorkbook.ActiveSheet.Name <> "Main" Or _
ActiveWorkbook.ActiveSheet.Name <> "Fixed" Then
ws.Activate
If Range("G2").Value = "" Then
ActiveSheet.Name = Range("G2").End(xlDown).Value
Else: ActiveSheet.Name = Range("G2").Value
End If
Else:
GoTo Nextsv
End If
Nextsv: Next ws
Sheets("Main").Activate
ActiveSheet.Cells(1, 1).Select
End Sub
Your code had 3 mistakes
You were using Activate and Active which produced the second error. Read this on how to avoid these.
You were checking the name of the ActiveSheet before the ws.Activate so it would always check the previous sheet.
Your conditions were with Or. Main <> Fixed so it would change their name anyways because Main is not Fixed and mets the second part of your Or and viceversa. Use And to force the code check that both conditions are met.
This is the code without using Activate or Select:
Option Explicit
Sub RenameSheets()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Main" And ws.Name <> "Fixed" Then
With ws
If .Range("G2") = vbNullString Then
.Name = .Range("G2").End(xlDown)
Else
.Name = .Range("G2")
End If
End With
End If
Next ws
End Sub
I have a VBA macro to check the existing 10 worksheets in the workbook and perform an analysis as shown below. I want to loop this code to do the analysis for 100 worksheets using For loop. I am stuck on how to combine AND condition and for loop? Help will be appreciated.
I have tried to use the for loop but failed.
Sub Mostoccurence()
'
' Mostoccurence Macro
'
'
Sheets.Add After:=ActiveSheet
Sheets("Sheet11").Select
Sheets("Sheet11").Name = "analysis"
Range("A1").Select
ActiveCell.FormulaR1C1 = _
"=AND(Sheet1!RC=1,Sheet2!RC=1,Sheet3!RC=1,Sheet4!RC=1,Sheet5!RC=1,Sheet6!RC=1,Sheet7!RC=1,Sheet8!RC=1,Sheet9!RC=1,Sheet10!RC=1)"
End Sub
Try something like this:
Option Explicit
Sub AddSheetCompare()
Dim oAnalysisSht As Worksheet
Dim oLoopSht As Worksheet
Dim lRow As Long
On Error Resume Next
Set oAnalysisSht = Worksheets("Analysis")
On Error GoTo 0
If oAnalysisSht Is Nothing Then
Set oAnalysisSht = ActiveWorkbook.Worksheets.Add(ActiveWorkbook.Worksheets(1))
oAnalysisSht.Name = "Analysis"
oAnalysisSht.Range("A1").Value = "Result of all worksheets"
oAnalysisSht.Range("A3").Value = "Worksheet Results"
End If
lRow = 3
For Each oLoopSht In Worksheets
If Not oLoopSht.Name = oAnalysisSht.Name Then
lRow = lRow + 1
oAnalysisSht.Range("A" & lRow).Formula = "='" & oLoopSht.Name & "'!A1=1"
End If
Next
oAnalysisSht.Range("A2").Formula = "=AND(A4:A" & lRow & ")"
End Sub
I have a really weird problem about VBA.
I tried to list circular references at activeworkbook and i have written below code for that. It only works if i press ALT+F11. So if VBA Editor window is open, code runs correctly but otherwise it is not working.
By the way, code is in a module at Addin and i call it from ribbon. You may see the code below.
Your help is highly appreciated. Bruteforce solution works. I hope someone can find decent solution than me.
Type SaveRangeCir
Val As Variant
Addr As String
Preaddress As String
Shtname As String
Workbname As String
End Type
Public OldCir() As SaveRangeCir
Sub DonguselBasvurulariBul(control As IRibbonControl)
Dim wba As Workbook
Dim ws As Worksheet
Dim wsa As Worksheet
Dim sht As Worksheet
Dim sht2 As Worksheet
Dim dummy As Worksheet
Dim Item As Range
Dim crcell As Range
Dim cll As Range
un = "Sayin " & Environ("UserName")
muyarcirc = MsgBox("Lutfen Oncelikle Dosyanizi Kaydedin" & vbNewLine & vbNewLine & _
"-->> Dosyanizi Kaydettiniz mi?", vbExclamation + vbYesNo, un)
If muyarcirc = vbno Then
muyar2 = MsgBox("Dongusel Basvuru Arama Islemi Iptal Edildi", vbInformation, un)
Exit Sub
End If
'BruteForce Solution
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
.VBE.MainWindow.Visible = True
.Wait Now + TimeValue("00:00:01")
.VBE.MainWindow.Visible = False
End With
On Error Resume Next
Set wba = ActiveWorkbook
Set wsa = wba.ActiveSheet
wba.Worksheets.Add
Set dummy = ActiveSheet
For Each sht2 In wba.Sheets
If sht2.Name = "Dongusel Basvurular" Then
sht2.Delete
End If
Next sht2
wba.Worksheets.Add
Set ws = wba.ActiveSheet
dummy.Delete
With ws
.Name = "Dongusel Basvurular"
.Range("A1") = "Dongusel Basvuru Hucresi"
.Range("B1") = "Dongusel Basvuru Hucresi Formul Degeri"
.Range("C1") = "Bagli Oldugu Alan"
.Range("D1") = "Bulundugu Sayfa"
.Range("E1") = "Bulundugu Dosya"
End With
With wba
For Each sht In .Worksheets
If sht.CodeName <> ws.CodeName Then
sht.Activate
crcell = Nothing
Do
Set crcell = sht.CircularReference
If Not crcell Is Nothing Then
ReDim Preserve OldCir(1 To crcell.Precedents.Cells.Count)
i = 0
For Each cll In crcell.Precedents
i = i + 1
OldCir(i).Addr = cll.Address
OldCir(i).Val = cll.Formula
OldCir(i).Preaddress = cll.Precedents.Address
OldCir(i).Shtname = cll.Parent.Name
OldCir(i).Workbname = cll.Parent.Parent.Name
cll.Value = cll.Value
Next cll
For j = LBound(OldCir) To UBound(OldCir)
lr = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ws.Cells(lr, 1) = OldCir(j).Addr
ws.Cells(lr, 2) = "'" & OldCir(j).Val
ws.Cells(lr, 3) = OldCir(j).Preaddress
ws.Cells(lr, 4) = OldCir(j).Shtname
ws.Cells(lr, 5) = OldCir(j).Workbname
ws.Hyperlinks.Add Anchor:=ws.Cells(lr, 1), Address:="", SubAddress:=ws.Cells(lr, 4) & "!" & ws.Cells(lr, 1), _
ScreenTip:="Dongusel Basvuru Hucresini Gormek icin Tiklayiniz"
Next j
Else
GoTo skipsheet
End If
Erase OldCir
Set crcell = sht.CircularReference
Loop While crcell.Cells.Count > 0
lr2 = ws.Cells(Rows.Count, 1).End(xlUp).Row
For m = 2 To lr2
If ActiveSheet.Name <> ws.Cells(lr2, "D") Then
wba.Sheets(ws.Cells(m, "D")).Activate
End If
Range(ws.Cells(m, 1)).Formula = "=" & Right(ws.Cells(m, 2), Len(ws.Cells(m, 2)) - 1)
Next m
End If
skipsheet:
Next sht
If ws.Range("A2") = "" Then
ws.Delete
wsa.Activate
m1 = MsgBox("Aktif Dosyada Dongusel Basvuru Bulunamadi", vbInformation, "Sayin " & Environ("UserName"))
Else
ws.Activate
ws.Range("A1:E1").EntireColumn.AutoFit
End If
End With
Erase OldCir
Set crcell = Nothing
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
I ran into a similar problem using VBA in MS Access. I understand you are using VBA Excel but I thought I'd post my personal experience in case it helps.
I have an Access form with a button that opens another form. The button is coded with VBA. If the VBA Editor was not open when I clicked the button then the new form would open but Form_Load() wouldn't trigger. If the VBA editor was open when I clicked the button then Form_Load() triggered as intended.
I did not have On Error Resume Next hiding any errors and all my variables were set with Option Explicit.
To troubleshoot the issue, I added a number of msgboxes throughout the code to narrow down where the problem was occurring. After adding a msgbox to the Click() event of the button I realized that the connection was somehow re-established and the code no longer needed the VBA editor open. After realizing this, I deleted the msgbox from the code, closed the application, re-opened the application without the VBA editor and from then on the VBA executed as intended.
Unfortunately, I came upon a solution while troubleshooting so I cannot provide an explanation as to why this worked but sometimes an explanation is not needed as long as you get it working again!
Hope this helps.
I had the same problem
However, it appeared have been caused by first using a message box with no return variable, then extending it to include a return, ie ret = msgbox(
Deleted the message box, code worked, closed and saved the project, reopened and message box with return variable added and now it run even without the editor open.
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
I am working on a simple subroutine to pull values from the Primary Worksheet and to move those values to the additional sheets. When I run the VBA macro it never gets past the subroutine declaration, any suggestions would greatly be appreciated.
Option Explicit
Sub Macro2()
Dim rCell As Range, ws As Worksheet
Application.DisplayAlerts = False
With Sheets("Sheet1")
Sheets.Add().Name = "Temp"
.Range("D2", .Range("D" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Temp").Range("B1"), Unique:=True
For Each rCell In Sheets("Temp").Range("D2", Sheets("Temp").Range("B" & Rows.Count).End(xlUp))
If Not IsEmpty(rCell) Then
.Range("D2").AutoFilter field:=3, Criteria1:=rCell
If SheetExists(rCell.Text) Then
Set ws = Sheets(rCell.Text)
Else
Set ws = Worksheet.Add(After:=Worksheets(Worksheets.Count - 1))
ws.Name = rCell
End If
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Copy ws.Range("A" & Rows.Count).End(xlUp)(2)
End With
End If
Next rCell
Sheets("Temp").Delete
.AutoFilterMode = False
End With
Application.DisplayAlerts = True
End Sub
added Function
Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
SheetExists = Not sht Is Nothing
End Function
New error
extract range has a illegal or missing field name
#
.Range("D2", .Range("D"&Rows.Count).End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Temp").Range("B1"), Unique:=True
When I run that code, it says:
Compile Error:
Sub or Function not defined
and then highlights the SheetExists function. Either SheetExist is a function you forgot to include in your form, or it's a custom function that wasn't included in your example.
EDIT: Wow, there's a lot going on here.
If you step through the code after that, you'll also get a Run-time 1004 error ("Application-defined or object-defined error") here:
.Range("D2", .Range("D" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Temp").Range("B1"), Unique:=True
Try changing that to:
.Range("D2", .Range("D" & Rows.Count).End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Temp").Range("B1"), Unique:=True
From there, change this:
Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count - 1))
ws.Name = rCell
to this:
Worksheets.Add(After:=Worksheets(Worksheets.Count - 1)).Name = rCell
From there, though, I'm not sure what With .AutoFilter.Range is supposed to be doing, unless you meant With Sheets("Sheet1").AutoFilter.Range.
From a debugging standpoint, you really want to add On Error Goto ErrRoutine at the beginning of your code, then add this to the end of your routine:
Exit Sub
ErrRoutine:
MsgBox Err.Description
Resume
And put a breakpoint on MsgBox Err.Description to step back to the offending line.
Have you debugged to see exactly where it fails. For example you aren't trying to add a Sheet called Temp when one already exists. Debug and find exactly where it fails.
I