This question already has answers here:
If Cell Contains This or That Paste onto Another Sheet
(2 answers)
Closed 3 years ago.
I'm a beginner when it comes to VBA and Macros; therefore, I'm not sure what the exact verbiage is but I believe I'm looking for help with looping.
My macro currently partially matches cells in each row in "SheetJS" containing either "Mercedes-Benz" or "BMW" and pastes the values to Column D in "Sheet1". However, it only copies the first iteration/cell that partially matches the text.
I want the macro to copy and past all matches. For example the 1st iteration should be copied/pasted to "Sheet1" Column D, 2nd in Column H, 3rd in L, and so on. Each iteration should have 3 cells in between.
I don't even know how to move forward with this.
Any tips would be greatly appreciated.
Thanks!
Sub Extract_Data_or()
For Each cell In Sheets("SheetJS").Range("A1:ZZ200")
matchrow = cell.Row
If (cell.Value Like "*Mercedez-Benz*") Or (cell.Value Like "*BMW*") Then
Sheets("Sheet1").Range("D" & matchrow).Value = cell.Value
End If
Next
End Sub
Edit 01.09.20
I want the macro to get all iterations/partial matches in each row and copy them. The current macro only copies the first match. I don't want to copy the entire row just the individual cells.
For example the first match in "SheetJS" should be copied to Column D in "Sheet1". The second match, (if any) should be copied to Column H, 3rd in column L, 4th in column P, etc. Every match should be placed 4 cells from each other.
SheetJS
All matches are highlighted in yellow. The values in each cell should copied over to "Sheet1"
Sheet1
The first match in each row is in Column D, the 2nd( if any) is in Columb H, etc.
You asked yesterday something similar. I asked for clarifications and I supplied a solution without receiving any sign from you...
Anyhow, maybe this time you will look at the next code and maybe test it. It works very fast, avoiding cells iteration. It works only in memory:
Private Sub Extract_Data_Bis()
Dim rngArr As Variant, dArr As Variant
Dim sh As Worksheet, i As Long, j As Long, k As Long
Dim lngOcc As Long, lngChanges As Long, boolFound As Boolean
Dim lngSameRow As Long, lngMised As Long
Set sh = Sheets("Sheet1")
rngArr = Sheets("SheetJS").Range("A1:ZZ200").Value
dArr = sh.Range("D1:F200").Value
For i = 1 To UBound(rngArr, 1)
boolFound = False: k = 0: lngSameRow = 0
For j = 1 To UBound(rngArr, 2)
If InStr(UCase(rngArr(i, j)), UCase("Mercedez-Benz")) > 0 Or _
InStr(UCase(rngArr(i, j)), "BMW") > 0 Then
If Not boolFound Then
lngSameRow = i
k = 1
Else
If lngSameRow = i Then
k = k + 1
End If
End If
lngOcc = lngOcc + 1: boolFound = True
If k <= 3 Then
dArr(i, k) = rngArr(i, j)
lngChanges = lngChanges + 1
Else
lngMised = lngMised + 1
End If
End If
Next j
Next i
sh.Range("D1:F200").Value = dArr
MsgBox lngOcc & " occurrences, versus " & lngChanges & " changes done. " & lngMised & " missed..."
End Sub
In case there are more then 3 occurrences on a row, at the end it makes a balance between occurrences, changes done and missed ones...
Related
I apologize, this is my first crack at Excel VBA so excuse my lack of knowledge!
So I have a list of (currently) 3 names to assign to the days in column A in a repeating order in Excel.
Currently my VBA code allows it to populate the selected cells with the names in a repeating pattern (this part is good), however there are two pieces I need help with.
1- with current code, once it reaches the bottom of the names it checks for the blank box that would end that list and starts over at the tops as directed but it puts a blank cell first (see screenshot). How can I have it put next name without adding blank cell first?
2- I want to be able to (once this gets going)select the entire D column through what dates need to be filled and:
-check the lowest non blank box
-match to list and set the
counter to name below that so
it continues the name order
from the last person who was
assigned
This is code I have now:
Sub EXAMPLE()
Dim count As Integer
count = 0
For Each c In Selection
c.Value = Range("X1").Offset(count, 0).Value
If c.Value = "" Then count = -1 And c.Value = Range("x1").Offset(count, 0).Value
count = count + 1
Next c
End Sub
Sorry I know that was long, I hope this makes sense.
I think it's worth reading about arrays, as this task is ideally suited to their use. Your best bet would be to read the names into an array and then build a recurring array whose dimension is equal to the number of rows in your dates column (or selection, or however you want to define the size of the output range).
Code would look a little like this:
Dim v As Variant
Dim people() As Variant, output() As Variant
Dim rowCount As Long, i As Long, j As Long
Dim endRange As Range
'Read the list of names into an array.
'This just takes all data in column "X" -> amend as desired
With Sheet1
Set endRange = .Cells(.Rows.Count, "X").End(xlUp)
v = .Range(.Cells(1, "X"), endRange).Value
End With
'Sense check on the names data.
If IsEmpty(v) Then
MsgBox "No names in Column ""X"""
Exit Sub
End If
If Not IsArray(v) Then
ReDim people(1 To 1, 1 To 1)
people(1, 1) = v
Else
people = v
End If
'Acquire the number of rows for repeating list of names.
'This just takes all data in column "A" -> amend as desired
With Sheet1
Set endRange = .Cells(.Rows.Count, "A").End(xlUp)
rowCount = .Range(.Cells(3, "A"), endRange).Rows.Count
End With
'Sense check date data.
If endRange.Row < 3 Then
MsgBox "No dates in Column ""A"""
Exit Sub
End If
'Make a recurring array.
ReDim output(1 To rowCount, 1 To 1)
i = 1
Do While i <= rowCount
For j = 1 To UBound(people, 1)
output(i, 1) = people(j, 1)
i = i + 1
If i > rowCount Then Exit Do
Next
Loop
'Write the output to column "D"
Sheet1.Range("D3").Resize(UBound(output, 1)).Value = output
I am trying to write a code that adds in data from my excel sheet if the item the user selects is equal to the range in J. This works perfectly if the range in J is filled in with all the data, but how do I get the row to still count all the way through the last filled cell if there are blanks in between? I attached a picture to show what I mean.
.
I would want to count the rows all the way down to the last "Gold". Right now it only counts to the second.
Private Sub cboName_Click() 'only get values that are assigned
Dim j As Integer, k As Integer, i As Integer
Me.lstProvider.Clear
i = 0
Worksheets("Biopsy Log").Select
For j = 1 To Range("J2", Range("J1").End(xlDown)).Rows.count
If Range("J2", Range("J2").End(xlDown)).Cells(j) = Me.cboName.Value Then
If Range("C2", Range("C2").End(xlDown)).Cells(j) = "Assigned" Then
With Me.lstProvider
.AddItem
For k = 0 To 5
.List(i, k) = Range("A" & j + 1).Offset(0, k)
Next
End With
i = i + 1
End If
End If
Next
End Sub
Instead of For j = 1 To Range("J2", Range("J1").End(xlDown)).Rows.count use Range("J" & Rows.Count).End(xlUp).Row (assuming GOLD is in column J). The code does the opposite of xlDown. It goes down to the last row of the sheet (Rows.count) and moves up until it find the first non-blank cell.
Instead of using xlDown, try to use xlUp from the bottom to get the last row for correct range:
Dim sht As Worksheet
Set sht = Worksheets("Biopsy Log")
For j = 1 To sht.Range("J" & sht.Rows.Count).End(xlUp).Row
If sht.Range(...)
Qualifying Range calls with an explicit Worksheet object makes your code more robust.
I have a worksheet, and the worksheet has multiple columns,multiple rows. How can I create a script such that, if a cell in any of those columns does not have a phrase, for example,'cat', the whole row gets deleted?
There are many solutions online, but they usually ask you to define a range, such as which column you want to search in and until how many rows. I can't have these restrictions as my different worksheets have different columns and different number of rows, but the same concept, where I delete a row if a certain phrase isn't existent in that row.
I am assuming that the word cat must appear somewhere in the row. If the row is completely "feline-free" then that row will be deleted. Here is a typical approach:
Sub KeepOnlyCatRows()
Dim i As Long, N As Long, s As String, c As String
N = Cells(Rows.Count, "A").End(xlUp).Row
c = Chr(1)
For i = N To 1 Step -1
s = c & Application.WorksheetFunction.TextJoin(c, True, Rows(i)) & c
If InStr(s, c & "cat" & c) = 0 Then
Rows(i).Delete
End If
Next i
End Sub
NOTES:
If the word cat must appear in every cell in the row, then ignore this answer.
I am assuming that the "cat-cell" contains only the word cat and no other text.
EDIT#1:
In order to allow an arbitrary word rather than cat, try the following:
Sub KeepOnlySpecialRows()
Dim i As Long, N As Long, s As String, c As String
Dim SpecialWord As String
N = Cells(Rows.Count, "A").End(xlUp).Row
c = Chr(1)
SpecialWord = Application.InputBox(Prompt:="Enter the special word:", Type:=2)
For i = N To 1 Step -1
s = c & Application.WorksheetFunction.TextJoin(c, True, Rows(i)) & c
If InStr(s, c & SpecialWord & c) = 0 Then
Rows(i).Delete
End If
Next i
End Sub
In a column filled mostly by blank cells, I need to get the value of the cell thats closest to the currently selected one, in a row before it, and isn't blank.
While the "isn't blank" part can be easily achieved with the an IF and ISBLANK statement, I can't figure out how to get the position of the first cell upwards from the current one that isn't blank.
In this example spreadsheet, in the cell C7 I want to display the value of B7 minus the value of B4 (=B7-B4). The problem is that these values are separated by an unpredictable number of cells, which can range from 0 to 20 or even more. Needing to parse a spreadsheet with thousands of rows and frequent data added, selecting the upper cell manually is not an option.
In continuation of my example, I want C13 to display =B13-B10, but lets say there were two more blank rows in between them (row 13 becomes row 15), I would want it to display =B15-B10.
Can the position be obtained with a MATCH query, knowing that the Types will always be T1 or T2?
Thank you in advance.
Enter this formula in cell C2 and drag it to the bottom.
=IFERROR(IF(B2="","",B2-LOOKUP(9.99999999999999E+307,B$1:B1)),"")
Writing formulae via VBA
Below you find a VBA approach writing your subtracting formulae to column C.
BTW, searching via array is much more quicker than looping through a range.
Code
Option Explicit
Sub subtractLastValueRow()
' declare vars
Dim oSht As Worksheet ' work sheet
Dim a As Variant ' one based 2-dim data field array
Dim n As Long ' last row in column B
Dim i As Long ' item no
Dim ii As Long ' last item no
Dim j As Long
Dim s As String
' set sheet
Set oSht = ThisWorkbook.Worksheets("MySheet") ' fully qualified reference to worksheet
' get last row number of search column
n = oSht.Range("B" & oSht.Rows.Count).End(xlUp).Row
If n < 2 Then Exit Sub ' only if data avaible (row 1 = title line)
' get range (after title line) values to one based 2dim data field array
a = oSht.Range("B2:C" & n).Value ' array gets data from e.g. "A2:A100"
' loop through column B to find keyword sKey
If Len(a(1, 1) & "") > 0 Then ii = 1 + 1 ' first item in array
For i = LBound(a) + 1 To UBound(a) ' array boundaries counting from 1+1 to n -1 (one off for title line)
' value found
If Len(a(i, 1) & "") > 0 Then
For j = i + 1 To UBound(a)
If Len(a(j, 1) & "") > 0 Then
' write .Formula (alternatively use .Value, if value wanted)
oSht.Range("C" & i + 1).Formula = "=B" & i + 1 & "-B" & ii
ii = i + 1 ' note last found i
Exit For
End If
Next j
End If
Next
If Len(a(UBound(a), 1) & "") > 0 Then ' last item in array
oSht.Range("C" & UBound(a) + 1).Formula = "=B" & UBound(a) + 1 & "-B" & ii
End If
End Sub
Note
If you want to write values instead of work sheet formulae, simply replace .Formula with .Value.
In cell C3 put following formula:
=B3-LOOKUP(2,1/$B$1:B2,$B$1:B2)
And copy down in all T2 cells as required.
I want to delete the entire rows for cell that contain 'Total' and 'Nett' in column C.
I have tried the macro recording using Auto Filter but it only delete rows up to a specified range (which may differ if I use other set of data).
Appreciate your help!
Here you go. Just copy and paste this sub into your file. To use it, select the SINGLE column that you want to evaluate. This will go through every cell that has been selected, and if it matches the criteria, it will delete the entire row. Let me know if you have any questions. Good luck!
Sub DeleteRows()
'Enter the text you want to use for your criteria
Const DELETE_CRITERIA = "Test"
Dim myCell As Range
Dim numRows As Long, Counter As Long, r As Long
'Make sure that we've only selected a single column
If Selection.Columns.Count > 1 Then
MsgBox ("This only works for a single row or a single column. Try again.")
Exit Sub
End If
numRows = Selection.Rows.Count - 1
ReDim arrCells(0 To 1, 0 To numRows) As Variant
'Store data in array for ease of knowing what to delete
Counter = 0
For Each myCell In Selection
arrCells(0, Counter) = myCell
arrCells(1, Counter) = myCell.Row
Counter = Counter + 1
Next myCell
'Loop backwards through array and delete row as you go
For r = numRows To 0 Step -1
If InStr(1, UCase(arrCells(0, r)), UCase(DELETE_CRITERIA)) > 0 Then
Rows(arrCells(1, r)).EntireRow.Delete
End If
Next r
End Sub
This will loop through cells in Column C and delete the entire row if the cell contains either "Total" or "Nett". Keep in mind that it is case sensitive, so the first letter of "Nett" or "Total" would need to be capitalized for this to find it. There can be other text in the cell however. Also note that the references are not fully qualified (ie Workbook().Worksheet().Range()) because you did not provide a workbook or worksheet name. Let me know if this does not work for you.
Sub Delete()
Dim i as Integer
For i = Range("c" & Rows.Count).End(xlUp).Row To 1 Step -1
If Instr(1, Cells(i, 3), "Total") <> 0 Or Instr(1, Cells(i,3),"Nett") <> 0 Then
Cells(i,3).EntireRow.Delete
End If
Next i
End Sub