I'm trying to write a Macro which will delete every row, apart from those which contain some specific text.
I need to have the following criteria:
Never delete the first 2 rows
Exclude the rows where the word "Somme" can be found in column C or D.
Note, the word Somme if part of a string in column C or D. An example of the text found would be something like:
Somme alpha/000284727819293
What I have so far is code which deletes rows with Somme in it, however i need the opposite:
Sub CleanUp()
Dim c As Range
Dim SrchRng
Set SrchRng = ActiveSheet.Range("D3", ActiveSheet.Range("D65536").End(xlUp))
Do
Set c = SrchRng.Find("Somme", LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Delete
Loop While Not c Is Nothing
End Sub
Give this a shot:
Sub SaveSomeRows()
Dim N As Long, L As Long, r As Range
Dim s As String, v As String
Set r = ActiveSheet.Range("D3", ActiveSheet.Range("D65536").End(xlUp))
N = r.Count
s = "somme"
For L = N To 1 Step -1
v = LCase(r(L).Value)
If InStr(1, v, s) = 0 Then
r(L).EntireRow.Delete
End If
Next L
End Sub
EDIT#1:
The initial version of the macro ignored column C.....try this instead:
Sub SaveSomeRows()
Dim N As Long, L As Long, r As Range
Dim s As String, v As String
Set r = ActiveSheet.Range("D3", ActiveSheet.Range("D65536").End(xlUp))
N = r.Count
s = "somme"
For L = N To 1 Step -1
v = LCase(r(L).Value & r(L).Offset(-1, 0).Value)
MsgBox v
If InStr(1, v, s) = 0 Then
r(L).EntireRow.Delete
End If
Next L
End Sub
Related
I am trying to write a function that loops through column values and applies numbers 1,2,3...n in between cells with strings. for example:
data:
hefew
1
3
2
6
bkifew
3
4
2
1
3
I want the function to change the values to:
hefew
1
1
1
1
bkifew
2
2
2
2
2
There could be multiple strings, so the end value could end up being 15 or so.
I have started a basic function but I am not familiar enough with VBA to work the logic. I program in Python and would normally do stuff like this in that language. However, I'm forced to keep this within excel.
current working:
Sub Button2_Click()
Dim rng As Range, cell As Range
cellcount = CountA("A1:A1000")
Set rng = Range("A1:A10")
For Each cell In rng
a = cell.Value
If IsNumeric(a) = True Then
cell.Value = 1
Else
cell.Value = 0
End If
Next cell
End Sub
I don't think this is possible with a for loop. Is there some sort of search and replace function that I could use?
Try this, assuming the numbers are not the result of formulae.
Sub x()
Dim r As Range, n As Long
For Each r In Columns(1).SpecialCells(xlCellTypeConstants, xlNumbers).Areas
n = n + 1
r.Value = n
Next r
End Sub
I created a function instead of sub which is little bit messy but it works. Tested at my pc
Public Function Test(checkrange As Range, checkcell As Range)
Dim cll As Range
Dim arr() As Variant
ReDim Preserve arr(1 To checkrange.Cells.Count)
If IsNumeric(checkcell.Value) = False Then
Test = checkcell.Value
Exit Function
End If
y = 1
For Each cll In checkrange
If IsNumeric(cll.Value) Then
arr(y) = 1
Else
arr(y) = 0
End If
y = y + 1
Next cll
m = 1
For Each cll In checkrange
If cll.Address = checkcell.Address Then
rownumber = m
Exit For
End If
m = m + 1
Next cll
m = 0
For i = LBound(arr) To UBound(arr)
If arr(i) = 0 Then
m = m + 1
End If
If i = rownumber Then Exit For
Next i
Test = m
End Function
There is user-defined function (UDF), which is located on all worksheets of the workbook.
How can I refer to the worksheet in which the function is located?
I am using ThisWorkbook.ActiveSheet, but the results are constantly changing.
Function äëÿñèò(Diapozon As Range) As Long
'äëÿ ñèòóàöèè
Application.Volatile
Dim n As Long
Dim C As Range
Dim m As Long
m = -1
n = 0
For Each C In Diapozon.Rows
If C.Value = 1 Then
m = m + 1
If ThisWorkbook.ActiveSheet.Cells(101, 42 + (m * 21)).Value = 1 Then
n = n + 1
End If
End If
Next C
äëÿñèò = n
End Function
You can use Application.Caller to refer to the cell which is calling the function, therefore you can use Application.Caller.Worksheet to refer to that cell's worksheet.
I do some macro and i upgrade a macro of Diedrich to have a MaxIfs in excel 2010 which work with line an columns i put the code under.
Public Function maxifs(MaxRange As Range, ParamArray Criteria() As Variant) As Variant
Application.Volatile
Dim n As Long
Dim i, j As Long
Dim c As Variant
Dim f As Boolean
Dim w() As Long
Dim k As Long
Dim z As Variant
'Error if less than 1 criteria
On Error GoTo ErrHandler
n = UBound(Criteria)
If n < 1 Then
'too few criteria
GoTo ErrHandler
End If
'Define k
k = 0
'Loop through cells of max range
For i = 1 To MaxRange.Count
For j = 1 To MaxRange.Count
'Start by assuming there is a match
f = True
'Loop through conditions
For c = 0 To n - 1 Step 2
'Does cell in criteria range match condition?
If Criteria(c).Cells(i, j).Value <> Criteria(c + 1) Then
f = False
End If
Next c
'Define z
z = MaxRange
'Were all criteria satisfied?
If f = True Then
k = k + 1
ReDim Preserve w(k)
w(k) = z(i, j)
End If
Next j
Next i
maxifs = Application.Max(w)
Exit Function
ErrHandler:
maxifs = CVErr(xlErrValue)
End Function
So now i will do the minifs and it does not work if all my value are positives.
How can i do?
ps: if you change in this macro max by median it will work too
Thanks for your answers.
It is because you are starting the array w with an empty slot at 0, since the first slot you fill is slot 1.
So w(0) is 0, Which when all the others are positive it is the minimum number.
So change K=-1 instead of K=0 When initially assigning value to k.
I also moved z in front of the loop, there is no reason to keep assigning that array. It only needs to be assigned once.
Also, I changed the ranges a little to only look at the used range, this way you can use full column references.
Also, the loops need to be through the rows and columns not two loops through the whole range as it causes many unnecessary loops.
Public Function minifs(MaxRange As Range, ParamArray Criteria() As Variant) As Variant
Application.Volatile
Dim n As Long
Dim i, j As Long
Dim c As Variant
Dim f As Boolean
Dim w() As Long
Dim k As Long
Dim z As Variant
'Error if less than 1 criteria
On Error GoTo ErrHandler
n = UBound(Criteria)
If n < 1 Then
'too few criteria
GoTo ErrHandler
End If
'Define z
z = Intersect(MaxRange, MaxRange.Parent.UsedRange).Value
'Define k
k = -1
'Loop through cells of max range
For i = 1 To UBound(z, 1)
For j = 1 To UBound(z, 2)
'Start by assuming there is a match
f = True
'Loop through conditions
For c = 0 To n - 1 Step 2
'Does cell in criteria range match condition?
If Intersect(Criteria(c), Criteria(c).Parent.UsedRange).Cells(i, j).Value <> Criteria(c + 1) Then
f = False
End If
Next c
'Were all criteria satisfied?
If f = True Then
k = k + 1
ReDim Preserve w(k)
w(k) = z(i, j)
End If
Next j
Next i
minifs = Application.Min(w)
Exit Function
ErrHandler:
minifs = CVErr(xlErrValue)
End Function
Also a note as this will only do = in the criteria and not any other function like >,<,<>,....
In the following code I have declared c to be used, but it seems as though it only works with numbers. I am looking for a string to compare with another string in another table on the same sheet.
The catch that makes this tricky is that I would like to offset the value to the cell adjacent to the left, and then compare one date with another. To make it more clear, my data is formatted like this: (Call it SetA)
A B C D E F G H I
CreateTime LotID AnalysisSet Slot# X Y ResultType TermName ResultName
A few more columns to the right.... Lets call this SetB
Y Z AA AB AC AD AE AF AG
CreateTime LotID AnalysisSet Slot# X Y ResultType TermName ResultName
Here is the code:
Sub AIM36DBOCompare()
Dim n As Integer
n = 2
Dim PasteCount As Integer
Dim test1 As Long
Dim test2 As Long
PasteCount = 41
Range("AD2:AD1000").Copy Destination:=Range("S41" & Lastrow)
Do While n <= 1000
If Cells(26, n) <> 0 Then
'--------------------------------------------
With Worksheets(1).Range("b2:b10000")
Set c = .Find(Cells(n, 26).String, LookIn:=xlValues)
If Not c Is Nothing Then
Do
test1 = Cells(n, 25).Value
test2 = c.Offset(0, -1)
If Abs(Cells(n, 25) - c.Offset(0, -1)) <= 100 Then
c.Offset(0, -1).Copy
Cells(PasteCount, 17).Select
Selection.Paste
PasteCount = PasteCount + 1
Exit Do
End If
Set c = .Find(Cells(n, 26).Value, LookIn:=xlValues)
Loop While Not c Is Nothing
End If
End With
'--------------------------------------------
End If
If Cells(11, n) = 0 Then
Exit Do
End If
n = n + 1
Loop
End Sub
So to be more clear here is the code: Find LotID in SetB, find the first (of multiple) corresponding LotID in SetA. Compare date in SetB to the date in SetA by offsetting the variable by one cell and then subtracting the two (using absolute value).
If it is under 100 days, then do stuff!
Its not doing stuff :(. The date in SetA is showing up as nothing. I think it is because of the variable being used. Please help!
The code fails at Test2 (and consequently) in the "if test" If Abs(Cells(n, 25) - c.Offset(-1, 0)) <= 100 Then
You mentioned that you want to take the cell to the left of c. In the code, you are getting the value from the cell above. To see this, try the code below:
Sub test()
Dim add As String
Dim c As Range
Dim offsetRange As Range
Set c = Range("B2")
Set offsetRange = c.Offset(-1, 0)
add = offsetRange.Address
Debug.Print add
Debug.Print offsetRange.Value
End Sub
Offset takes rows first, then columns, so you would want to swap to 0 and -1, as below:
Sub test2()
Dim add As String
Dim c As Range
Dim offsetRange As Range
Set c = Range("B2")
Set offsetRange = c.Offset(0, -1)
add = offsetRange.Address
Debug.Print add
Debug.Print offsetRange.Value
End Sub
Also, you are declaring and getting the values for the variables test1 and test2, but you are not using these values when doing the comparison.
I found this piece of code that searches through the H column in a sheet and copies the cells which contain the word "apply" in a new workbook.
I then tried to change it so it would copy the entire row, but can't figure out what I'm doing wrong, as it now just opens a new workbook and leaves it empty.
Can someone look at the code and tell me what I'm doing wrong?
Many thanks
Sub test()
Dim K, X As Long, r As Range, v As Variant
K = 1
X = 5
Dim w1 As Workbook, w2 As Workbook
Set w1 = ThisWorkbook
Set w2 = Workbooks.Add
w1.Activate
For Each r In Intersect(Range("H:H"), ActiveSheet.UsedRange)
v = r.Value
X = X + 1
If InStr(v, "applied") > 0 Then
'**Initial line** - r.Copy w2.Sheets("Sheet1").Cells(K, 1)
With w2
w1.Sheets("Sheet1").Rows("X:X").Copy .Sheets("Sheet1").Rows("K")
K = K + 1
End With
End If
Next r
End Sub
There are multiple errors in your code.
You are using strings for row references. "X:X" will resolve to the string X:X. It will not substitute the value of X inside the string. Same for "K" on sheet 2.
you are copying the row five below the row in which you find "applied".
If you want to copy the same row, I would suggest:
Dim K, X As Long, r As Range, v As Variant
K = 1
Dim w1 As Workbook, w2 As Workbook
Set w1 = ThisWorkbook
Set w2 = Workbooks.Add
w1.Activate
For Each r In Intersect(Range("H:H"), ActiveSheet.UsedRange)
v = r.Value
X = X + 1
If InStr(v, "applied") > 0 Then
r.EntireRow.Copy w2.Sheets("Sheet1").Rows(K)
K = K + 1
End If
Next r
You could also change the Copy line to:
r.EntireRow.Copy w2.Sheets("Sheet1").Cells(K, 1)
but I don't know if the one is more efficient than the other.