I have an error which prevents me to run properly my macro. When I try to run my macro, I have the error message runtime error 1004 application defined or object defined error
I checked my code, the error comes from this part of my code: Range("K1") = "= SUM(" & thirdRow & "B:B" & LastRow & ")"
It seems that the part “B:B” of this line is not properly recognized in my code. In fact, I would like my macro to return in cell K1 the value of the sum of my third cell in column B to my last cell in column B; in this case, 587,29 (please see screenshot enclosed I circled it in red).
Many thanks in advance.
Xavi
Sub jfdjdgfjg()
Dim i as Long, counter As Long
Dim thirdcell As Range
Dim r As Range
Set r = ActiveCell
Dim LastRow As Long
Dim thirdRow As Long
LastRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
Range("B1").Activate
For i = 2 To LastRow 'assuming a header row not to be counted
If r.Rows(i).EntireRow.Hidden = False Then counter = counter + 1
If counter = 2 Then
Set thirdcell = r.Cells(i, "A")
Exit For
End If
Next i
Debug.Print thirdcell
Debug.Print LastRow
thirdRow = thirdcell.Row
Debug.Print thirdRow
Range("K1") = "= SUM(" & thirdRow & "B:B" & LastRow & ")"
End Sub
Related
I am working with a dataset that contains both numbers and names. In the dataset, some numbers and names are displayed and instead of manually going through thousands of rows I tried to make a script but it doesn´t happen anything.
Here is the code:
Sub MoveCells()
Dim row As Long
For row = 2 To LastRow
If Range("C" & row).Value Like "*0*" Then
Dim i As Integer
For i = 1 To 2
Range("C" & row).Insert Shift:=xlToRight
Next
End If
Next
End Sub
I am trying to move the cell that has a 0 in it, and the cell to the right of it, one step to right.
E.g. Cells C4 & D4 to D4 & E4.
I've made some adjustments to your code which will acheive the outcome you described.
Private Sub MoveCells()
Dim TargetRow As Long
Dim LastRow As Long
Dim ColumnCValue As Variant
Dim ColumnDValue As Variant
With Sheets("Sheet1")
LastRow = .Cells(.Rows.Count, 3).End(xlUp).row
End With
For TargetRow = 2 To LastRow
If Sheets("Sheet1").Range("C" & TargetRow).Value Like "*0*" Then
ColumnCValue = Sheets("Sheet1").Range("C" & TargetRow).Value
ColumnDValue = Sheets("Sheet1").Range("D" & TargetRow).Value
Sheets("Sheet1").Range("D" & TargetRow).Value = ColumnCValue
Sheets("Sheet1").Range("E" & TargetRow).Value = ColumnDValue
Sheets("Sheet1").Range("C" & TargetRow).ClearContents
End If
Next
End Sub
Now we first assign a value to for LastRow and when the If...Then statement is true, assign the values of Column C and Column D to the respective variables. Then, write those values 1 row to the right and finally clear the contents from Column C.
Okay, so I feel like I am getting closer but I am running in to an object error. I am trying to replace old values in an excel sheet with the new charge values. Here is an example of what I am trying to do.
This is an example of the type of table I might start out with.
This is what I want it to look like after I run the VBA
Here is what I have so far.
Sub Testing()
Dim x As Integer
Dim UpdateRng As Range
Dim SelectRng As Range
v = 2
Application.ScreenUpdating = False
' Get count
NumRows = Range("B2", Range("B2").End(xlDown)).Rows.Count
Range("B2").Select
' Cycle through loop
For x = 1 To NumRows
Set SelectRng = Range("C" & v & ":" & "F" & v) 'Set range
If "A" & v.Vaule = " " Or v.Value = "" Then GoTo NextV
For Each UpdateRng In SelectRng
If UpdateRng.Value > 0 Then
UpdateRng.Value = Range("A" & v).Value
End If
Next
NextV:
v = v + 1
Next
Application.ScreenUpdating = True
End Sub
Add Option Explicit to the top of the module and declare all variables.
Avoid using GoTo as that generally creates spaghetti code.
Use End(xlUp) to determine the last row.
Avoid using Select.
Use Long instead of Integer.
Sub Testing()
Dim ws As Worksheet
Set ws = ActiveSheet
With ws
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
Dim i As Long
For i = 2 To lastRow
With ws
If Not IsEmpty(.Range("A" & i).Value) Then
.Range("C" & i & ":F" & i).Replace "*", .Range("A" & i).Value
End If
End With
Next
End Sub
Note that this considers all values when replacing, not just values greater than 0. Though I think the >0 check is essentially checking if the cells in columns C:F are not empty.
I got it working with this. However, Bigben's is much cleaner.
Sub Testing()
Dim x As Integer
Dim UpdateRng As Range
Dim SelectRng As Range
v = 2
Application.ScreenUpdating = False
' Get count
NumRows = Range("B2", Range("B2").End(xlDown)).Rows.Count
Range("B2").Select
' Cycle through loop
For x = 1 To NumRows
Set SelectRng = Range("C" & v & ":" & "F" & v) 'Set range
If Range("A" & v).Value = " " Or Range("A" & v).Value = "" Then GoTo NextV
For Each UpdateRng In SelectRng
If UpdateRng.Value > 0 Then
UpdateRng.Value = Range("A" & v).Value
End If
Next
NextV:
v = v + 1
Next
Application.ScreenUpdating = True
End Sub
I wanted to convert below formula to VBA code.
=C1&"`"&K1&"`"&L1&"`"&J1
=VLOOKUP(M1,Data!$A:$J,9,)
=SUMPRODUCT(SUMIF(B1:B,B1,G1:G))
Currently i have enter this formula in 1st row and than copying this formula till the last row used which is taking lot time to apply formula because it has more than million row.
LR1 = Sheets("CRIMS").UsedRange.Rows.Count
Sheets("CRIMS").Range("M1:P1").AutoFill Destination:=Sheets("CRIMS").Range("M1:P" & LR1)
is there any way to convert this formula into VBA code?
For first formula the easiest way would be:
Range("M" & i).FormulaR1C1 = "=RC[-10]&""`""&K&""`""&L&""`""&J"
But for vlookup I prefer dictionaries/collections! It is much much faster.
If You have source data in Data sheet and You want to put that to CRIMS sheet to column M:
Sub vlookup()
Dim names As Range, values As Range
Dim lookupNames As Range, lookupValues As Range
Dim vlookupCol As Object
Dim lastRow As Long
Dim lastRow2 As Long
Dim objekt as Object
With Sheets("Data")
lastRow = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).row
Set names = Sheets("Data").Range("A1:A" & lastRow)
Set values = Sheets("Data").Range("I1:A" & lastRow)
End With
Set objekt = BuildLookupCollection(names, values)
With Sheets("CRIMS")
lastRow2 = 1000000
Set lookupNames = .Range("M1:M" & lastRow)
Set lookupValues = .Range("N1:N" & lastRow)
End With
VLookupValues lookupNames, lookupValues, objekt
Set objekt = Nothing
End Sub
Function BuildLookupCollection(categories As Range, values As Range)
Dim vlookupCol As Object, i As Long
Set vlookupCol = CreateObject("Scripting.Dictionary")
On Error Resume Next
For i = 1 To categories.Rows.Count
Call vlookupCol.Add(CStr(categories(i)), values(i))
Next i
On Error GoTo 0
Set BuildLookupCollection = vlookupCol
End Function
Sub VLookupValues(lookupCategory As Range, lookupValues As Range, vlookupCol As Object)
Dim i As Long, resArr() As Variant
ReDim resArr(lookupCategory.Rows.Count, 1)
For i = 1 To lookupCategory.Rows.Count
resArr(i - 1, 0) = vlookupCol.Item(CStr(lookupCategory(i)))
Next i
lookupValues = resArr
End Sub
Quotation Marks need to be doubled in VBA
Try this:
For i = 1 To LR1
Range("M" & i).Formula = "=C" & i & "&""`""&K" & i & "&""`""&L" & i & "&""`""&J" & i
Range("N" & i).Formula = "=VLOOKUP(M" & i & ",Data!$A:$J,9,)"
Next i
(replace column letters with actual target column)
As mentioned in the comments Looping in this case is highly inefficient.
Use this Code to insert the formulas all at once. It still takes some time for 1 Milion rows though.
Range("M1:M" & LR1).Formula = "=C:C & ""`"" & K:K & ""`"" & L:L & ""`"" & J:J"
Range("N1:N" & LR1).Formula = "=VLOOKUP(M:M,Data!$A:$J,9,)"
My goal is to make a code that takes in the percent error from sheet 1 (column F) and then if the percent error if below 0.5% it takes the values from columns A:D that correspond with column f (for example if F6 had a percent error below 0.5% the program would copy A6:D6) and copies the cells and pastes them into sheet 2. Then this program needs to loop through all the values in column f and repeat this process.
I have had success with copying and pasting the cells I need using the code below without the If statement. However, I cannot seems to get a code that depends on the percent error.
'The start of the command button
Private Sub CommandButton1_Click()
Dim i As Long
Dim ii As Long
Dim i3 As Long
Dim LastRow As Long
Dim wb As Workbook
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim Myrange As Range
Dim PerecntError As Integer
Set wb = ThisWorkbook
Set sht1 = wb.Sheets("RawData")
Set sht2 = wb.Sheets("FilteredData")
'Find the last row (in column A) with data.
LastRow = sht1.Range("A:A").Find("*", searchdirection:=xlPrevious).Row
ii = 2
i = 3
'This is the beginning of the loop
For i = 1 To LastRow
If sht1.Range("F" & ii < 0.5) Then
'First activity
sht2.Range("A" & ii) = sht1.Range("A" & i).Value
sht2.Range("B" & ii) = sht1.Range("B" & i).Value
sht2.Range("C" & ii) = sht1.Range("C" & i).Value
sht2.Range("D" & ii) = sht1.Range("D" & i).Value
ii = ii + 1
i = i + 1
End If
Next
End Sub
The error I am getting is that "Type mismatch"
for this line: "If sht1.Range("F" & ii < 0.5) Then"
Any help would be greatly appreciated.
If sht1.Range("F" & ii < 0.5) Then
should be
If sht1.Range("F" & ii) < 0.5 Then
The below code needs to run the =disvincenty formula on a loop, and the referenced cells $C$2,$D$2 need to go down one row each time in same column each time code block runs until ABF (Last row with data in column T.) then it exit's sub
For each row, it needs to run the formulas =Min and the two =small's in the same columns already referenced, but also dropping down one row at a time - the same as the =distvincenty, but values being pasted each time to preserve result.
So =distvincenty is looking at two criteria in cells next to each other on same row, compares to a list running down a column, applies the three other formulas to that row, and moves down.
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim ABF As Integer
ABF = Sheet9.Range("T" & Rows.Count).End(xlUp).row
Set rng = Range("Q2:Q" & ABF)
For Each row In rng.Rows
For Each cell In row.Cells
Sheet9.Range("Q2").Formula = "=distVincenty($C$2,$D$2,$R2,$S2)/1609.344"
Sheet9.Range("Q2").Copy
Sheet9.Range("Q2:Q" & ABF).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Sheet9.Range("E2").Formula = "=MIN(Q:Q)"
Sheet9.Range("H2").Formula = "=SMALL(Q:Q,2)"
Sheet9.Range("K2").Formula = "=SMALL(Q:Q,3)"
Next cell
Next row
UPDATE:
I now have this:
Dim ABF As Integer
Dim i As Integer
For i = 2 To Sheet9.Range("A" & Rows.Count).End(xlUp).row
ABF = Sheet10.Range("AC" & Rows.Count).End(xlUp).row
Sheet10.Range("AE3").Formula = "=distVincenty('Booking Workings'!$C$2,'Booking Workings'!$D$2,'User List'!$Z3,'User List'!$AA3)/1609.344"
Sheet10.Range("AE3").Copy
Sheet10.Range("AE3:AE" & ABF).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Sheet9.Range("E" & i).Formula = "=MIN('User List'!AE:AE)"
Sheet9.Range("H" & i).Formula = "=SMALL('User List'!AE:AE,2)"
Sheet9.Range("K" & i).Formula = "=SMALL('User List'!AE:AE,3)"
Next i
End sub
The only problem I have is that each time this code runs, I need the $C$2 and $D$2 to change like the simpler formulas.
Can I do this?
Sheet10.Range("AE3").Formula = "=distVincenty('Booking Workings'!$C$"(I)",'Booking Workings'!$D$"(I)",'User List'!$Z3,'User List'!$AA3)/1609.344"
UPDATE
looks like this works:
"=distVincenty('Booking Workings'!$C$" & (i) & ",'Booking Workings'!$D$" & (i) & ",'User List'!$Z3,'User List'!$AA3)/1609.344"
This is hard to explain. Let me know if I'm close.
Sub Test()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim ABF As Integer
Dim arrValues
Dim count As Integer
ABF = Sheet9.Range("T" & Rows.count).End(xlUp).row
Set rng = Range("Q2:Q" & ABF)
arrValues = rng.Value
For Each cell In rng
Sheet9.Range("Q2:Q" & ABF).Formula = "=distVincenty($C$" & cell.row & ",$D$" & cell.row & ",$R2,$S2)/1609.344"
Sheet9.Range("E2").Formula = "=MIN(Q:Q)"
Sheet9.Range("H2").Formula = "=SMALL(Q:Q,2)"
Sheet9.Range("K2").Formula = "=SMALL(Q:Q,3)"
count = count + 1
arrValues(count) = cell.Value
Next cell
Sheet9.Range("Q2:Q" & ABF).Value = arrValues
End Sub