I have a real hard time putting my logic into excel vba code.
My logic: Comparing cells to cells, if cell A > cell B then continue to loop to the next column. When all the cell from the same column have the same value, then delete the whole column.
Sub deletecol()
Dim LastCol As Range, LastRow As Range, rRange As Range
Dim i As Integer, j As Integer
LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
With ActiveSheet
For i = 1 To LastRow
For j = 1 To LastCol
If ActiveSheet.Cells(1, 1).Value = ActiveSheet.Cells(i, 1).Value Then
Column(j).EntireColumn.Delete
Else
ActiveSheet.Cells(1,1).Value > ActiveSheet.Cells(i,j).Value Then [this is the part that I'm stuck]
Next j
Next i
End With
End Sub
I believe what you are currently doing is just comparing the cell objects. If you want the values, you must specifically ask for the value.
ActiveSheet.Cells(1,1).Value > ActiveSheet.Cells(i, j).Value
As for using the above as another condition, you might want to look into the Elseif keyword.
Consider the following code
If Range("a2").Value > 0 Then
Range("b2").Value = "Positive"
ElseIf Range("a2").Value < 0 Then
Range("b2").Value = "Negative"
End If
This page does a pretty decent job at explaining conditional controls in VBA
https://www.automateexcel.com/vba/else-if-statement
Related
i am looking for a solution to my problem. The task is to compare two consecutive rows with each other,in the range from column D1 to the last written cell in Column D. If the value of a consecutive cell is equal to the value of the previous cell , i.e. D2=D1, the macro can go next, else it shall insert a new row between the two values. Since i am fairly new to vba and mostly use information based on online research, i could not find a fitting solution til now. Below you can see a part of what tried.
Sub Macro()
'check rows
Dim a As Long
Dim b As Long, c As Long
a = Cells(Rows.Count, "D").End(xlUp).Row
For b = a To 2 Step -1
c = b - 1
If Cells(b, 4).Value = Cells(c, 4).Value Then
If Cells(b, 4).Value <> Cells(c, 4).Value Then
Rows("c").Select
Selection.Insert Shift:=xlDown
End If
End If
Next b
End Sub
Sub InsertRows()
Dim cl As Range
With ActiveSheet
Set cl = .Cells(.Rows.Count, "D").End(xlUp)
Do Until cl.Row < 2
Set cl = cl.Offset(-1)
If cl.Value <> cl.Offset(1).Value Then cl.Offset(1).EntireRow.Insert
Loop
End With
End Sub
Side note. You can benefit from reading How to avoid using Select in Excel VBA
I´ve developed a small macro on Excel using VBA, which compares the information on column C and copies the formating information contained on column F on sheet(3).
The code is working well, however, I´m trying to optimize it. I would like to avoid copying the formating when a given cell already contains the intended formating. Something like:
If Range("C7").Offset(i, 0).***FORMATING*** = Sheets(3).Range("F7").Offset(j, 0).***FORMATING*** Then
Unfortunately, I haven't been able to identify the attribute that defines the formatting of a cell.
Please see below the current code I have:
Sub Contract()
Application.ScreenUpdating = False
Dim i As Integer, j As Integer, Lastrow As Integer, Lastrow2 As Integer
Sheets(1).Activate ' activa a sheet(1)
Lastrow = Cells(Rows.Count, "C").End(xlUp).Row
Lastrow2 = Sheets(3).Cells(Rows.Count, "F").End(xlUp).Row
For i = 0 To Lastrow - Range("c7").Row
For j = 0 To Lastrow2 - Range("F7").Row
If Range("C7").Offset(i, 0).Value = Sheets(3).Range("F7").Offset(j, 0).Value Then
Sheets(3).Range("F7").Offset(j, 0).Copy
Range("C7").Offset(i, 0).PasteSpecial Paste:=xlPasteFormats
Exit For
End If
Next j
Next i
End Sub
Thank you for the help.
We have a single formula which we are coping to over to a defined range of over 250'000 cells. The performance of Excel clearly takes a hit. Is there a way to improve the performance by using VBA?
The formula returns either 0 or 1 as a value to the cell depending on 4 criteria. The Excel formula is:
=IF(NOT(ISTEXT($B9)),"",IF((L$5=""),"",IF(AND(M$5>MIN($G9,$H9),L$5<MAX($G9,$H9)),1,0)))
Thanks for your help !
Something like this could be an alternative to 250,000 rows of formulas. As stated in the comments, this still would take some time given the size of the data set. I ran a test with a sheet that just had the necessary cells populated with 249,488 rows and the code took 12 seconds to run. With more data in the sheet I anticipate it taking longer than that.
That said this will reduce the memory of your file significantly since there won't be any formulas:
Sub Run()
Dim i As Long 'Row number for loop
Dim lRow As Long 'Last row of data set
Dim ms As Worksheet
Set ms = Sheets("Sheet1") 'Change to whatever sheet you need this in
With ms
If .Cells(5, 12).Value = "" Then
MsgBox "Please enter a value in Cell L5 before proceeding."
Else
lRow = .Cells(.Rows.Count, 2).End(xlUp).Row 'This is assuming Column B is populated in full to the bottom of the data set
For i = 9 To lRow 'This is assuming you will be starting the calculation in row 9
If IsNumeric(.Cells(i, 2).Value) = False And .Cells(i, 2).Value <> "" Then 'Ensuring Column B is text and not blank
If .Cells(5, 12).Value < WorksheetFunction.Max(.Cells(i, 7).Value, .Cells(i, 8).Value) And .Cells(5, 13).Value > WorksheetFunction.Min(.Cells(i, 7).Value, .Cells(i, 8).Value) Then
.Cells(i, 1).Value = 1 'Assuming you want the 0 or 1 in Column A
Else
.Cells(i, 1).Value = 0 'Assuming you want the 0 or 1 in Column A
End If
End If
Next i
End If
End With
End Sub
EDIT
Per Cornintern's awesome suggestion, I've rewritten this to use arrays instead of looping through the entire range. This now takes less than 2 seconds:
Sub Run()
Dim i As Long 'Row number for loop
Dim lRow As Long 'Last row of data set
Dim ms As Worksheet
Dim mVar1() As Variant
Dim mVar2() As Variant
Dim mVar3() As Variant
Dim rVar() As Variant
Dim num1 As Long
Dim num2 As Long
Set ms = Sheets("Sheet1") 'Change to whatever sheet you need this in
With ms
If .Cells(5, 12).Value = "" Then
MsgBox "Please enter a value in Cell L5 before proceeding."
Else
lRow = .Cells(.Rows.Count, 2).End(xlUp).Row 'This is assuming Column B is populated in full to the bottom of the data set
ReDim rVar(1 To lRow - 8) As Variant
mVar1 = .Range("G9:G" & lRow)
mVar2 = .Range("H9:H" & lRow)
mVar3 = .Range("B9:B" & lRow)
num1 = .Cells(5, 12).Value
num2 = .Cells(5, 13).Value
For i = 1 To UBound(mVar1) 'This is assuming you will be starting the calculation in row 9
If IsNumeric(mVar3(i, 1)) = False And mVar3(i, 1) <> "" Then 'Ensuring Column B is text and not blank
If num1 < WorksheetFunction.Max(mVar1(i, 1), mVar2(i, 1)) And num2 > WorksheetFunction.Min(mVar1(i, 1), mVar2(i, 1)) Then
rVar(i) = 1
Else
rVar(i) = 0
End If
End If
Next i
End If
End With
Range("A9:A" & lRow) = WorksheetFunction.Transpose(rVar)
End Sub
Given that your formula is simple I would expect that the formula approach would calculate faster/better than VBA:
Excel calculates using multiple cores: VBA only uses 1
The overhead of transferring data to VBA and back to Excel is
substantial
Excel can calculate over a million simple formulas per second
Excel can automatically recalculate efficiently if any of the data
changes, but you would have to rerun the entire VBA sub.
I would recommend seeing how long the formula approach takes in practice: I would be surprised if it calculates in more than a second.
I am trying to go through row 6 and from column 1 to 26 and search for the sentence Earned Cumulative Hours. Once that is done then I am trying to go from row 8 to the last row(30 in this case) for the column that has Earned Cumulative Hours in row 6.
Then I am trying to paste the values of the cells from this column to 2 cells left in the same row. But I keep getting errors and the code doesn't work.
Can someone please point me in the right direction ? Thanks
Sub project()
Dim lastrow As Long
Dim i As Long
Dim j As Long
lastrow = Sheets("Progress").Cells(Rows.Count, 26).End(xlUp).Row
For j = 1 To 26
If Cells(6, j) = "Earned Cumulative Hours" Then
For i = 8 To lastrow
Cells(i, j).Copy
Cells(i, j).Offset(0, -2).Select
Selection.PasteSpeical Paste:=xlPasteValues
Next i
End If
Next j
End Sub
There are a few problems I can see straight away with your code. Firstly if you are offsetting back two columns .Cells(i, j).Offset(0, -2) then you will be overwriting existing values. If this is what you intend to do then weird but ok.
The next issue is that you have a problem if 'Earned Cumulative Hours' is in Column A. If this is your case Excel will be most unhappy trying to offset two columns to the left and will give an error.
In this case instead of copying and pasting it will be more efficient to set values in one column to the other which you can see in my code. Finally, your Cell references will be valid for the active sheet only. You need to qualify what worksheet you interest in as shown in my code. I normally put this at the start of the code if it is a self contained block.
You could also eliminate the i loop and set ranges of values at a time but we'll save that for next time!
I haven't test this code but it should be fine.
Sub projectawesome()
Dim lastrow as Long, i as Long, j as Long
'Qualify the sheet (assuming its in the activeworkbook)
With Sheets("Progress")
lastrow = .Cells(.Rows.Count, 26).End(xlUp).Row
'I've changed this to column three to prevent offset errors.
For j = 3 to 26
If .Cells(6, j) = "Earned Cumulative Hours" Then
For i = 8 to lastrow
'Assuming overwriting data is ok.
'No need to copy and paste
.Cells(i, j - 2).Value = .Cells(i, j).Value
Next i
End If
Next
End With
End Sub
Try this and we can get rid of those selects
Sub project()
Dim lastrow As Long
Dim i As Long
Dim j As Long
lastrow = Sheets("Progress").Cells(Rows.Count, 26).End(xlUp).Row
For j = 1 To 26
If Cells(6, j) = "Earned Cumulative Hours" Then
For i = 8 To lastrow
Cells(i, j).Copy
With Cells(i, j)
.Offset(0, -2).PasteSpecial xlPasteValues
End With
Next i ' next row
End If
Next j ' next col
End Sub
I want to delete negative values in a range in excel. I have a code that deletes but not all the values.
I got to know that I should first change the value to numeric type. I have the below code in which I have tried to do so with cDec and Convert.ToInt32 but not successful. I am new to vba, I don't know much about its data types. Your help will be highly appreciable:
Sub Button1_Click()
Dim ws As Worksheet
Dim i As Integer
i = 1
Set ws = Sheets("Recovered_Sheet1")
ws.Activate
Dim r As Excel.Range
For Each r In Range("A1:A250").Rows
If Not IsEmpty(ActiveCell.Value) Then
'move to the row below
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = CDec(ActiveCell.Value)
End If
Next r
Do While Cells(i, 1).Value <> ""
If Cells(i, 1) < 0 Then
Cells(i, 1).EntireRow.Delete
End If
i = i + 1
Loop
End Sub
Here is one way of doing that. Note that when deleting rows, you should work from the bottom up. Also, you don't need to change the Excel data type before running this macro, unless you have some other reason to do so (in which case there are more efficient methods than going cell by cell).
Edit Since text and blanks will return False with .Value < 0, there's no need to test anything else.
Option Explicit
Sub DelNegNumRows()
Dim I As Long
For I = 250 To 1 Step -1
With Cells(I, 1)
If .Value < 0 Then
.EntireRow.Delete
End If
End With
Next I
End Sub
Depending on the characteristics of your range, you may not need to check all 250 rows (although if that is the size of your database, you won't perceive a speed advantage to making the range smaller). For example, if all of your rows with data are non-blank, you can do something like:
lastrow = cells(1,1).end(xldown).row
or, if there might be blanks, and you want to find the last row in column A that has any data, something like:
lastrow = cells(rows.Count,1).end(xlup).row
You could then cycle, in the macro above:
for I = lastrow to 1 step -1
Sub Button1_Click()
Dim I As Long
Dim lastrow As Long
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
For I = lastrow To 1 Step -1
With Cells(I, 2)
If .Value < 0 Then
.EntireRow.Delete
End If
End With
Next I
End Sub