macros can't see a worksheet - 'runtime error 9' - excel

I have 2 sheets and 1 macros that pastes values from one to another. The macros is working. I copied it and changed it a bit. But it can't run -
'run time error 9'
which is visibility issue.
All sheets are in same excel file.
original macros code, it works:
Sub original()
For j = 18 To 28
Worksheets("Express_vnzp").Select
srok = Cells(26, j).Value
stav = Cells(31, j).Value
komis = Cells(28, j).Value
stavka_privlech = Cells(29, j).Value
For i = 10 To 12
PD = Cells(i, 17).Value
Worksheets("Ðàñ÷åòû").Select
Cells(3, 2).Value = stav
Cells(4, 2).Value = srok
Cells(5, 2).Value = komis
Cells(7, 2).Value = stavka_privlech
Cells(15, 2).Value = PD
marzha2 = Cells(23, 2).Value
Worksheets("Express_vnzp").Select
Cells(i, j).Value = marzha2
Next
Next
End Sub
I copied and changed i,j - not working.
Sub erj()
For j = 3 To 4
Worksheets("creditcard").Select
srok = Cells(26, j).Value
stav = Cells(31, j).Value
komis = Cells(28, j).Value
stavka_privlech = Cells(29, j).Value
For i = 5 To 6
PD = Cells(i, 17).Value
Worksheets("ras").Select
Cells(3, 2).Value = stav
Cells(4, 2).Value = srok
Cells(5, 2).Value = komis
Cells(7, 2).Value = stavka_privlech
Cells(15, 2).Value = PD
marzha2 = Cells(23, 2).Value
Worksheets("creditcard").Select
Cells(i, j).Value = marzha2
Next
Next
End Sub
gives 'runtime error', its visibility issue.

Related

Editing Excel from Access VBA Object Required Error

I have a program that opens an Excel spreadsheet and makes changes to it. I am always editing the first sheet but if it is a certain type of report I want to edit the second sheet as well. This all works fine for me on the first sheet and all but centering the text in the cell on the second sheet. I get an Object Required error only when I try to do this. I center the text in the cells on the first sheet no problem. The error only comes after I pass the object to the new procedure. Here is some of my code:
First Procedure
Private Sub OSummary1(strfile As String, strTableResults As String, dtUnivDt As Date)
Dim xlApp As Object
Dim objWorkbook As Object
Dim objSheet As Object
Set xlApp = CreateObject("Excel.Application")
Set objWorkbook = xlApp.Workbooks.Open(strfile)
Set objSheet = objWorkbook.Sheets(1)
Later in the code
ElseIf Mid(strTableResults, 11, 1) = 1 Then
Max = 11
Do Until i > Max
If .Cells(i, 4).Value = "0" And .Cells(i, 2).Value = "0" And .Cells(i, 3).Value = "0" Then
.Cells(i, 4).Value = "NA"
.Cells(i, 4).Interior.ColorIndex = 15
.Cells(i, 3).Value = "-"
.Cells(i, 2).Value = "-"
ElseIf .Cells(i, 2).Value = "0" Then
.Cells(i, 4).Value = "0.0"
.Cells(i, 4).Interior.ColorIndex = 22
ElseIf .Cells(i, 4).Value >= "95.00" Or .Cells(i, 4).Value = "100" Then
.Cells(i, 4).Interior.ColorIndex = 43
ElseIf .Cells(i, 4).Value >= "90.00" And .Cells(i, 4).Value < "95.00" Then
.Cells(i, 4).Interior.ColorIndex = 36
Else
.Cells(i, 4).Interior.ColorIndex = 22
End If
If .Cells(i, 4).Value = 0 Then
.Cells(i, 4).NumberFormat = "0.00%"
ElseIf Not .Cells(i, 4).Value Like "*.*" Then
.Cells(i, 4).NumberFormat = "#.00""%"""
ElseIf .Cells(i, 4).Value Like "*.#" Then
.Cells(i, 4).NumberFormat = "#.#0""%"""
Else
.Cells(i, 4).NumberFormat = "#.##""%"""
End If
If .Cells(i, 1).Value = "AppealNotificationTimeliness" Then
.Cells(i, 1).Font.Bold = True
.Cells(i, 2).Font.Bold = True
.Cells(i, 3).Font.Bold = True
.Cells(i, 4).Font.Bold = True
.Cells(i, 2).HorizontalAlignment = xlCenter
.Cells(i, 3).HorizontalAlignment = xlCenter
.Cells(i, 4).HorizontalAlignment = xlCenter
iB = Len(.Cells(i, 2).Value)
iC = Len(.Cells(i, 3).Value)
iD = .Cells(i, 4).Value
Else
'Indent header
.Cells(i, 1).IndentLevel = 3
'Indent sub-headers
If iB < 3 Then
.Cells(i, 2).IndentLevel = 5
ElseIf iB > 2 And iB < 5 Then
.Cells(i, 2).IndentLevel = 4
ElseIf iB > 4 And iB < 7 Then
.Cells(i, 2).IndentLevel = 3
Else
.Cells(i, 2).IndentLevel = 2
End If
If iC < 3 Then
.Cells(i, 3).IndentLevel = 4
ElseIf iC > 2 And iC < 5 Then
.Cells(i, 3).IndentLevel = 3
ElseIf iC > 4 And iC < 7 Then
.Cells(i, 3).IndentLevel = 2
Else
.Cells(i, 3).IndentLevel = 1
End If
If iD = "NA" Then
.Cells(i, 4).IndentLevel = 5
ElseIf iD = "100" Then
.Cells(i, 4).IndentLevel = 3
Else
.Cells(i, 4).IndentLevel = 4
End If
End If
i = i + 1
Loop
If Right(strTableResults, 3) = "FDR" Then
Call FDRTable1(objWorkbook)
End If
This all works fine for sheet 1
Second Procedure from Call above
Private Sub FDRTable1(ByRef objWorkbook As Object)
Dim objSheet As Object
Dim RowCnt As Integer
Dim CurrentRow As Integer
Dim CurrentRowVal As String
Dim iRange As Range
Dim iCells As Range
Dim i As Integer
Dim Max As Integer
Set objSheet = objWorkbook.Sheets(2)
i = 2
With objSheet
'Header
.Cells(1, 1).Font.Size = 12
.Range("A1:G1").Font.Bold = True
.Cells.EntireColumn.AutoFit
.Range("A2:G6").BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
.Range("A7:G9").BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
.Range("A10:G14").BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
.Range("A15:G17").BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
Max = 17
Do Until i > Max
If .Cells(i, 7).Value = "0" And .Cells(i, 4).Value = "0" And .Cells(i, 6).Value = "0" Then
.Cells(i, 7).Value = "NA"
.Cells(i, 7).Interior.ColorIndex = 15
.Cells(i, 4).Value = "-"
.Cells(i, 5).Value = "-"
.Cells(i, 6).Value = "-"
ElseIf .Cells(i, 4).Value = "0" Then
.Cells(i, 7).Value = "0.0"
.Cells(i, 7).Interior.ColorIndex = 22
ElseIf .Cells(i, 7).Value >= "95.00" Or .Cells(i, 7).Value = "100" Then
.Cells(i, 7).Interior.ColorIndex = 43
ElseIf .Cells(i, 7).Value >= "90.00" And .Cells(i, 7).Value < "95.00" Then
.Cells(i, 7).Interior.ColorIndex = 36
Else
.Cells(i, 7).Interior.ColorIndex = 22
End If
If .Cells(i, 7).Value = 0 Then
.Cells(i, 7).NumberFormat = "0.00%"
.Cells(i, 4).HorizontalAlignment.xlCenter
.Cells(i, 5).HorizontalAlignment.xlCenter
.Cells(i, 6).HorizontalAlignment.xlCenter
.Cells(i, 7).HorizontalAlignment.xlCenter
ElseIf Not .Cells(i, 7).Value Like "*.*" Then
.Cells(i, 7).NumberFormat = "#.00""%"""
.Cells(i, 4).HorizontalAlignment.xlCenter
.Cells(i, 5).HorizontalAlignment.xlCenter
.Cells(i, 6).HorizontalAlignment.xlCenter
.Cells(i, 7).HorizontalAlignment.xlCenter
ElseIf .Cells(i, 7).Value Like "*.#" Then
.Cells(i, 7).NumberFormat = "#.#0""%"""
.Cells(i, 4).HorizontalAlignment.xlCenter
.Cells(i, 5).HorizontalAlignment.xlCenter
.Cells(i, 6).HorizontalAlignment.xlCenter
.Cells(i, 7).HorizontalAlignment.xlCenter
Else
.Cells(i, 7).NumberFormat = "#.##""%"""
.Cells(i, 4).HorizontalAlignment.xlCenter
.Cells(i, 5).HorizontalAlignment.xlCenter
.Cells(i, 6).HorizontalAlignment.xlCenter
.Cells(i, 7).HorizontalAlignment.xlCenter
End If
i = i + 1
Loop
End With
End Sub
This all works too except I get the error when I try to center the text (.HorizontalAlignment.xlCenter). If I remove those lines, it works fine.

VBA code not entering else if and end if loop

I have the below loop written, however I am having issues with the code entering the else if loop and to have the loop until (end if) the ranges equal each other. Essentially I want the loop to add 2 to the cells that contain "Corporates" first and afterwards add 1 to the cells that have a the number 2.
Dim x As Long
Dim V As Variant
V = Cells(Rows.Count, 1).End(xlUp).Row
JV = Range("J" & Rows.Count).End(xlUp).Row
For x = 1 To V
If Cells(x, 2).Value = "Corporates" Then
Cells(x, 7).Value = Cells(x, 7).Value + 1
ElseIf Cells(x, 12).Value < "3%" And Cells(x, 2).Value = "Corporates" Then
Cells(x, 7).Value = Cells(x, 7).Value + 1
End If
Range("J" & JV + 3).Value = Range("J" & JV + 2).Value
Next x
End Sub
Use a nested If instead of ElseIf
I'm guessing that < "3%" should be < 0.03 ("3%" is text, not a number).
If Cells(x, 2).Value = "Corporates" Then
If Cells(x, 12).Value < 0.03 Then
Cells(x, 7).Value = Cells(x, 7).Value + 2
Else
Cells(x, 7).Value = Cells(x, 7).Value + 1
End If
End If

Trying to delete empty rows in VBA with command button

i'm trying to solve a problem of mine and i'm pretty much a newbie in VBA.
I'm trying to make a quotation out of excel utilizing user form.
Transferring data is doable from the user form, but am having some difficulty to complete the quotation:
1. Creating new empty row base on input in user form
2. assign input to different rows and deleting any empty rows if there are no input.
This is my userform:
Private Sub okaybutton_Click()
'Make quotation activate
Sheet11.Activate
'Trasnfer Information sheet
Cells(2, 6).Value = DateBox.Value
Cells(6, 2).Value = "Company: " + CompanyBox.Value
Cells(8, 2).Value = "State: " + StateBox.Value
Cells(9, 2).Value = "Name: " + PICBox.Value
Cells(10, 2).Value = "Contact Number: " + ContactCustomer.Value
Cells(7, 2).Value = "Address: " + AddressBox.Value
Cells(7, 6).Value = SEBox.Value
Cells(8, 6).Value = CNBox.Value
Cells(11, 2).Value = CusEmail.Value
Cells(9, 6).Value = ACemail.Value
If PTWrequire.Value = True Then
Cells(13, 2).Value = "PTW application or safety induction required at site"
End If
If ESDrequire.Value = True Then
Cells(13, 2).Value = Cells(13, 2).Value & " " & " & ESD Attire required."
End If
'SupplySide information sheet
'Determine emptyRow
nextrow = WorksheetFunction.CountA(Range("B:B"))
nextrow1 = WorksheetFunction.CountA(Range("B:B")) + 1
nextrow2 = WorksheetFunction.CountA(Range("B:B")) + 2
'Dim nextrow As Long
'nextrow = Cells(Rows.Count, "A").End(xlUp).Row + 1
'flow measurement point 1
If FlowMeasure1.Value = True Then
Cells(nextrow, 3).Value = "Flow measurement, Measures dry air flow capacity."
If Hottap1.Value = "Yes" Then
Cells(nextrow, 3).Value = Cells(nextrow, 3).Value & "- perform hot tapping on " & "Main header size: " & Pipesize1.Value & """."
Else
Cells(nextrow, 3).Value = Cells(nextrow, 3).Value & " Main header size: " & Pipesize1.Value & """."
End If
If Pipesize1.Value = 2 Then
Cells(nextrow, 4).Value = "3700"
ElseIf Pipesize1.Value = 2.5 Then
Cells(nextrow, 4).Value = "3706"
ElseIf Pipesize1.Value = 3 Then
Cells(nextrow, 4).Value = "3945"
ElseIf Pipesize1.Value = 4 Then
Cells(nextrow, 4).Value = "3971"
ElseIf Pipesize1.Value = 5 Then
Cells(nextrow, 4).Value = "3971"
ElseIf Pipesize1.Value = 6 Then
Cells(nextrow, 4).Value = "4080"
End If
If SSquantity1.Value > 0 Then
Cells(nextrow, 2).Value = SSquantity1.Value
End If
'flow measurement point 2
If Hottap2.Value = "Yes" Then
Cells(nextrow1, 3).Value = "Flow measurement, Measures dry air flow capacity." & "- perform hot tapping on " & "Main header size: " & Pipesize2.Value & """."
ElseIf Hottap2.Value = "No" Then
Cells(nextrow1, 3).Value = Cells(nextrow1, 3).Value & " Main header size: " & Pipesize2.Value & """."
End If
If Pipesize2.Value = 2 Then
Cells(nextrow1, 4).Value = "3700"
ElseIf Pipesize2.Value = 2.5 Then
Cells(nextrow1, 4).Value = "3706"
ElseIf Pipesize2.Value = 3 Then
Cells(nextrow1, 4).Value = "3945"
ElseIf Pipesize2.Value = 4 Then
Cells(nextrow1, 4).Value = "3971"
ElseIf Pipesize2.Value = 5 Then
Cells(nextrow1, 4).Value = "3971"
ElseIf Pipesize2.Value = 6 Then
Cells(nextrow1, 4).Value = "4080"
End If
If SSquantity2.Value > 0 Then
Cells(nextrow1, 2).Value = SSquantity2.Value
End If
'flow measurement point 3
If Hottap3.Value = "Yes" Then
Cells(nextrow2, 3).Value = "Flow measurement, Measures dry air flow capacity." & "- perform hot tapping on " & "Main header size: " & Pipesize3.Value & """."
ElseIf Hottap3.Value = "No" Then
Cells(nextrow2, 3).Value = Cells(nextrow2, 3).Value & " Main header size: " & Pipesize3.Value & """."
End If
If Pipesize3.Value = 2 Then
Cells(nextrow2, 4).Value = "3700"
ElseIf Pipesize3.Value = 2.5 Then
Cells(nextrow2, 4).Value = "3706"
ElseIf Pipesize3.Value = 3 Then
Cells(nextrow2, 4).Value = "3945"
ElseIf Pipesize3.Value = 4 Then
Cells(nextrow2, 4).Value = "3971"
ElseIf Pipesize3.Value = 5 Then
Cells(nextrow2, 4).Value = "3971"
ElseIf Pipesize3.Value = 6 Then
Cells(nextrow2, 4).Value = "4080"
End If
If SSquantity3.Value > 0 Then
Cells(nextrow2, 2).Value = SSquantity3.Value
End If
End If
On Error Resume Next
Worksheet.Columns("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
End Sub

How to sum and remove duplicates on 2 columns

Application Match for one column works but for 2 columns is giving me error
With Sht
LastRow = .Cells(.Rows.Count, "J").End(xlUp).Row
For i = LastRow To 2 Step -1
DupRow = Application.Match(Cells(i, 9).Value, Range(Cells(1, 9), Cells(i - 1, 9)), 0)
DoEvents
If Not IsError(DupRow) Then
Cells(i, 8).Value = Cells(i, 8).Value + Cells(DupRow, 8).Value
Cells(i, 9).Value = Cells(i, 9).Value + Cells(DupRow, 9).Value
Rows(DupRow).Delete
End If
Next i
End With
for 2 columns Error runtime 1004
DupRow = Application.Match(Cells(i, 4).Value & Cells(i, 5).Value, Range(Cells(1, 4) & Cells(1, 5), Cells(i - 1, 4) & Cells(i - 1, 5)), 0)
What is the correct way of doing this?
In my opinion it's better to use dictionary for that, which has built-in method for managing keys, so it can be used to get unique values:
Sub teest()
Dim val As String
Set dict = CreateObject("Scripting.Dictionary")
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = LastRow To 2 Step -1
val = Cells(i, 1).Value & Cells(i, 2).Value
If dict.Exists(val) Then
Rows(i).Delete
Else
dict.Add val, 0
End If
Next
End Sub

Sum of all the iterations of a variable in VBA

I have the following code
Dim i As Integer
For i = 3 To 10
If Range("H3").Value = Cells(i, 2).Value And Range("I3").Value < Cells(i, 4).Value And _
Range("I3").Value >= Cells(i, 3).Value Then
Range("J3").Value = Cells(i, 5).Value
End If
Next i
I want the value of J3 to represent the sum of all the iterations and not just the last iteration if i. Can it be done?
While there are certainly better methods of adding up cells, for your particular method this should work.
Dim i As long, lTotal as long
For i = 3 To 10
If Range("H3").Value = Cells(i, 2).Value And Range("I3").Value < Cells(i, 4).Value And _
Range("I3").Value >= Cells(i, 3).Value Then
lTotal = Cells(i, 5).Value + lTotal
End If
Next i
Range("J3").Value = lTotal
Keep a running total of of your loop, then use the running total as your cell's value after you've finished the loop
Change this line
Range("J3").Value = Cells(i, 5).Value
To:
Range("J3").Value = Range("J3").Value + Cells(i, 5).Value

Resources