VBA value range doing strange - excel

So how do i put this i am a vba rookie and i have been trying to make an excel file and the purpose is that it should be an inventory of all items one sheet is for putting items in and other is for giving them away. But that is not the problem, the thing is i wanted to have a page called "databaseinventory" where all products that are taken out are writen down but my value is doing strange. (look at the image)
So this is the input screen and if i type this
this is the output on a different sheet but i don't want it to be 0
I noticed if i change the input and add 3 rows it works but that prevents me of typing more then one product
this is the output that i want to have and i really don't know what is wrong with the code
Sub Btn_Clickweggegeven()
Dim x As Long
Dim Givenaway As Worksheet
Dim Inventory As Worksheet
Dim productn As String
Dim erow As Long
Dim rng As Range
Dim rownumber As Long
Dim row As Long
Dim wsData As Worksheet
Dim wsIn As Worksheet
Dim nextRow As Long
Dim BtnText As String
Dim BtnNum As Long
Dim strName As String
x = 2
Do While Cells(x, 1) <> ""
' go through each item on list
productn = Cells(x, 1)
' if item is not new then add quanity to total Inventory
With Worksheets("Inventory").Range("A:A")
Set rng = .Find(What:=productn, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
'if item is new add item to the bottom of Inventory list
If rng Is Nothing Then
erow = Worksheets("Inventory").Cells(1, 1).CurrentRegion.Rows.Count + 1
Worksheets("Inventory").Cells(erow, 1) = Worksheets("Givenaway").Cells(x, 1)
Worksheets("Inventory").Cells(erow, 2) = Worksheets("Givenaway").Cells(x, 2)
Worksheets("Inventory").Cells(erow, 3) = Worksheets("Givenaway").Cells(x, 3)
Worksheets("Inventory").Cells(erow, 4) = Worksheets("Givenaway").Cells(x, 4)
GoTo ende
Else
rownumber = rng.row
End If
End With
Worksheets("Inventory").Cells(rownumber, 2).Value = Worksheets("Inventory").Cells(rownumber, 2).Value _
- Worksheets("Givenaway").Cells(x, 2).Value
Worksheets("Inventory").Cells(rownumber, 4).Value = Worksheets("Inventory").Cells(rownumber, 4).Value _
+ Worksheets("Givenaway").Cells(x, 2).Value
ende:
x = x + 1
Loop
'after complete delete items from Givenaway list
Worksheets("Givenaway").Select
row = 2
Do While Cells(row, 1) <> ""
Range(Cells(row, 1), Cells(row, 3)).Select
Selection.Delete
Loop
Set wsIn = Worksheets("Givenaway")
Set wsData = Worksheets("Databaseinventory")
With wsData
nextRow = .Cells(.Rows.Count, "A") _
.End(xlUp).Offset(1, 0).row
End With
With wsData
With .Cells(nextRow, 1)
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(nextRow, 2).Value = productn
.Cells(nextRow, 3).Value = Worksheets("Databaseinventory").Cells(rownumber, 3).Value _
+ Worksheets("Givenaway").Cells(x, 2).Value
End With
End Sub

This code is deleting the value
Worksheets("Givenaway").Select
row = 2
Do While Cells(row, 1) <> ""
Range(Cells(row, 1), Cells(row, 3)).Select
Selection.Delete
Loop
before this line copies it to Databaseinventory
Cells(nextRow, 3).Value = Worksheets("Databaseinventory").Cells(rownumber, 3).Value _
+ Worksheets("Givenaway").Cells(x, 2).Value
It appears to work if you have 3 rows is because on exit from the Do While Cells(x, 1) <> "" loop the value of x will be 3. After deleting the first record then Worksheets("Givenaway").Cells(x, 2).Value will be the value for the third record.
The database update routine also need to be within the loop
Option Explicit
Sub Btn_Clickweggegeven()
Dim wb As Workbook, rng As Range
Dim wsInv As Worksheet, wsGiven As Worksheet, wsData As Worksheet
Dim iRow As Long, iDataRow As Long, iInvRow As Long
Dim sProduct As String, nValue As Single
Set wb = ThisWorkbook
Set wsGiven = wb.Sheets("GivenAway")
Set wsInv = wb.Sheets("Inventory")
Set wsData = wb.Sheets("Databaseinventory")
iDataRow = wsData.Cells(Rows.Count, 1).End(xlUp).row
iRow = 2
With wsGiven
Do While .Cells(iRow, 1) <> ""
sProduct = .Cells(iRow, 1)
nValue = .Cells(iRow, 2)
' if item is not new then add quanity to total Inventory
With wsInv.Range("A:A")
Set rng = .Find(What:=sProduct, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With
If rng Is Nothing Then
iInvRow = wsInv.Cells(Rows.Count, 1).End(xlUp).row + 1
wsInv.Cells(iInvRow, 1).Resize(1, 4).Value = .Cells(iRow, 1).Resize(1, 4).Value
Else
iInvRow = rng.row
wsInv.Cells(iInvRow, 2).Value = wsInv.Cells(iInvRow, 2).Value - nValue
wsInv.Cells(iInvRow, 4).Value = wsInv.Cells(iInvRow, 4).Value + nValue
End If
' write to database
iDataRow = iDataRow + 1
With wsData.Cells(iDataRow, 1)
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
.Offset(0, 1) = sProduct ' col B
.Offset(0, 2) = wsInv.Cells(iInvRow, 3).Value + nValue ' col C ??
End With
iRow = iRow + 1
Loop
End With
'delete from GivenAway
wsGiven.Range("A2").Resize(iRow, 3).Delete
MsgBox iRow - 2 & " records processed", vbInformation
End Sub

Related

VBA chart creation from scattered data rows

I'm creating a UI for entering, editing, exporting, importing patient data (cholesterol biomarkers).
I've encountered a problem with the need to display available data from a "Data" worksheet.
The Data looks like this:
What I need is to create a chart from available data of ,, Elizbeth Norton,, with date in X-axis and Chol, Trig, LDL, HDL (separate lines) in Y-axis.
The results are being managed by using a Userform with a Listbox (from which a button should create the chart when found data is selected. Data is selected in a Listbox)
and this code finds needed data and puts selected results into an array
The Userform:
Code to find needed data:
If Len(f_FindAll.TextBox_Find.Value) >= 3 Then 'Do search if text in find box is longer than 3 character.
Set SearchRange = ActiveWorkbook.Worksheets("Data").Range("C:E").Cells
FindWhat = f_FindAll.TextBox_Find.Value
'Calls the FindAll function
Set FoundCells = FindAll(SearchRange:=SearchRange, _
FindWhat:=FindWhat, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
MatchCase:=False, _
BeginsWith:=vbNullString, _
EndsWith:=vbNullString, _
BeginEndCompare:=vbTextCompare)
If FoundCells Is Nothing Then
ReDim arrResults(1 To 1, 1 To 5)
arrResults(1, 1) = "Data not found!!!"
Else
'Add results of FindAll to an array
ReDim arrResults(1 To FoundCells.Count, 1 To 5)
lFound = 1
For Each FoundCell In FoundCells
If FoundCell.Column = 3 Then
arrResults(lFound, 1) = FoundCell.Offset(0, -1).Value
arrResults(lFound, 2) = FoundCell.Value
arrResults(lFound, 3) = FoundCell.Offset(0, 1).Value
arrResults(lFound, 4) = FoundCell.Offset(0, 2).Value
arrResults(lFound, 5) = FoundCell.Address
lFound = lFound + 1
Else
If FoundCell.Column = 4 Then
arrResults(lFound, 1) = FoundCell.Offset(0, -2).Value
arrResults(lFound, 2) = FoundCell.Offset(0, -1).Value
arrResults(lFound, 3) = FoundCell.Value
arrResults(lFound, 4) = FoundCell.Offset(0, 1).Value
arrResults(lFound, 5) = FoundCell.Address
lFound = lFound + 1
Else
If FoundCell.Column = 5 Then
arrResults(lFound, 1) = FoundCell.Offset(0, -3).Value
arrResults(lFound, 2) = FoundCell.Offset(0, -2).Value
arrResults(lFound, 3) = FoundCell.Offset(0, -1).Value
arrResults(lFound, 4) = FoundCell.Value
arrResults(lFound, 5) = FoundCell.Address
lFound = lFound + 1
End If
End If
End If
Next FoundCell
End If
'Populate the listbox with the array
Me.ListBox_Results.List = arrResults
Code to display selected data in a user form:
Private Sub ListBox_Results_Click()
'Go to selection on the sheet when the result is clicked
Dim strAddress As String
Dim l As Integer
For l = 0 To ListBox_Results.ListCount
If ListBox_Results.Selected(l) = True Then
strAddress = ListBox_Results.List(l, 4)
Rownum = Range(strAddress).Row
Colnum = Range(strAddress).Column
ActiveWorkbook.Worksheets("Data").Select
Cells(Rownum, Colnum).Select
'Populate textboxes with results
'and maybe populate chart data range with results aswell????
With ActiveWorkbook.Worksheets("Data")
f_FindAll.TextBox_Results1.Value = .Cells(.Range(strAddress).Row, 1).Value
f_FindAll.TextBox_Results2.Value = .Cells(.Range(strAddress).Row, 2).Value
f_FindAll.TextBox_Results3.Value = .Cells(.Range(strAddress).Row, 3).Value
f_FindAll.TextBox_Results4.Value = .Cells(.Range(strAddress).Row, 4).Value
f_FindAll.TextBox_Results5.Value = .Cells(.Range(strAddress).Row, 5).Value
f_FindAll.TextBox_Results6.Value = .Cells(.Range(strAddress).Row, 6).Value
f_FindAll.TextBox_Results7.Value = .Cells(.Range(strAddress).Row, 7).Value
f_FindAll.TextBox_Results8.Value = .Cells(.Range(strAddress).Row, 8).Value
f_FindAll.TextBox_Results9.Value = .Cells(.Range(strAddress).Row, 9).Value
f_FindAll.TextBox_Results10.Value = .Cells(.Range(strAddress).Row, 10).Value
f_FindAll.TextBox_Results11.Value = .Cells(.Range(strAddress).Row, 11).Value
f_FindAll.TextBox_Results12.Value = .Cells(.Range(strAddress).Row, 12).Value
End With
GoTo EndLoop
End If
Next l
EndLoop:
End Sub
So what would be the best option? Maybe instead sort the data in sheet "Data" and create a chart from the selected range?
Thank you for your help.
One way would be to build a collection of row numbers and then use them to create arrays for each series of the chart. Alternatively dump the array to another sheet and use that as the source data.
Option Explicit
Sub PlotData()
Dim wb As Workbook, ws As Worksheet
Dim rngSearch As Range, rngFound As Range
Dim FindWhat As String, FirstFound As String
Dim datarows As Collection, ar
Dim r As Long, i As Integer, n As Integer
Set wb = ThisWorkbook
Set ws = wb.Sheets("Data")
Set datarows = New Collection
Set rngSearch = ws.UsedRange.Columns("C:E")
' build collection of rows
FindWhat = "11342"
Set rngFound = rngSearch.Find(FindWhat, _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=False)
If rngFound Is Nothing Then
' no match
Exit Sub
Else
FirstFound = rngFound.Address
Do
n = n + 1
datarows.Add rngFound.Row, CStr(n)
Set rngFound = rngSearch.FindNext(After:=rngFound)
Loop While Not rngFound Is Nothing And rngFound.Address <> FirstFound
End If
' fill array
ReDim ar(1 To n, 1 To 5), x(n - 1), y(n - 1)
Dim sname
sname = Array("date", "chol", "trig", "LDL", "HDL")
For i = 1 To n
With ws
r = datarows(i)
x(i - 1) = .Cells(r, "B") 'date
ar(i, 1) = .Cells(r, "B") 'date
ar(i, 2) = .Cells(r, "I") 'chol
ar(i, 3) = .Cells(r, "J") 'trig
ar(i, 4) = .Cells(r, "K") 'LDL
ar(i, 5) = .Cells(r, "L") 'HDL
End With
Next
' copy to sheet if required as source data for plot
'Sheet2.Range("A1:E1") = sname
'Sheet2.Range("A2:E" & n + 1) = ar
' plot graph
Dim cht As Chart, c As Integer, srs As Series
Set cht = ws.Shapes.AddChart(xlLineMarkers).Chart
With cht
.HasTitle = True
.ChartTitle.Text = FindWhat
For c = 2 To 5
'Define the array of values for each series
For i = 1 To n
y(i - 1) = ar(i, c)
Next
Set srs = .SeriesCollection.NewSeries
With srs
.XValues = x
.Values = y
.name = sname(c - 1)
End With
Next
.Location Where:=xlLocationAsNewSheet, name:=FindWhat
End With
MsgBox "Done"
End Sub

For Each loop on filtered data returning 0 results, no errors

I need to generate a sheet of values out of a database between dates that the user selects. The date is in column 2 of the database, but I need the whole row for every date in this range. I got some advice to use a For Each instead to more easily use the SpecialCells(xlCellTypeVisible). While I am no longer getting any errors I also get no data in my product worksheet. Could someone tell me why I am not returning data?
Sub Generate()
Dim g As Integer
Dim h As Integer
Dim datemin As String
Dim datemax As String
datemin = CDbl(CDate(Sheets("start").Cells(15, 8)))
datemax = CDbl(CDate(Sheets("start").Cells(15, 9)))
Worksheets("Database").Range("A1").AutoFilter Field:=10, Criteria1:=">=" & datemin, _
Operator:=xlAnd, Criteria2:="<=" & datemax
g = 0
For Each Row In Worksheets("database").Range("A1")
g = g + 1
If Cells(g, 1).SpecialCells(xlCellTypeVisible) = True And Cells(g, 1) <> "" Then
Sheets("product").Activate
Dim NextRow As Long
NextRow = Application.WorksheetFunction.CountA(Range("A:A")) + 10
'fill KPI
Cells(NextRow, 1) = Format(Sheets("database").Cells(g, 1), "mm/dd/yyyy") 'Date1
Cells(NextRow, 2) = Format(Sheets("database").Cells(g, 2), "mm/dd/yyyy") 'Date2
Cells(NextRow, 3) = Sheets("database").Cells(g, 3) 'value1
Cells(NextRow, 4) = Sheets("database").Cells(g, 4) 'value2
Cells(NextRow, 6) = Sheets("database").Cells(g, 5) 'value3
Cells(NextRow, 9) = Sheets("database").Cells(g, 8) 'comment
Cells(NextRow, 13) = Sheets("database").Cells(g, 6) 'person
Else
Exit For
End If
Next
End Sub
You are only 'looping' through one cell - A1.
If you want to use a loop for this try looping through all the rows on the database and checking if they are visible or not.
If they are visible then copy the relevant data to the other sheet.
Sub Generate()
Dim rngDst As Range
Dim rngSrc As Range
Dim datemin As String
Dim datemax As String
Dim g As Integer
Dim h As Integer
datemin = CDbl(CDate(Sheets("start").Cells(15, 8)))
datemax = CDbl(CDate(Sheets("start").Cells(15, 9)))
Worksheets("Database").Range("A1").AutoFilter Field:=10, Criteria1:=">=" & datemin, _
Operator:=xlAnd, Criteria2:="<=" & datemax
Set rngSrc = Worksheets("Database").Range("A2")
Set rngDst = Worksheets("Product").Range("A11")
Do
If Not rngSrc.EntireRow.Hidden And rngSrc.Value <> "" Then
'fill KPI
rngDst.Value = Format(rngSrc.Value, "mm/dd/yyyy") 'Date1
rngDst.Offset(, 1).Value = Format(rngSrc.Offset(, 1).Value, "mm/dd/yyyy") 'Date2
rngDst.Offset(, 2).Value = rngSrc.Offset(, 2).Value 'value1
rngDst.Offset(, 3).Value = rngSrc.Offset(, 3).Value 'value2
rngDst.Offset(, 5).Value = rngSrc.Offset(, 4).Value 'value3
rngDst.Offset(, 8).Value = rngSrc.Offset(, 7).Value 'comment
rngDst.Offset(, 12).Value = rngSrc.Offset(, 5).Value 'person
Set rngDst = rngDst.Offset(1, 0)
End If
Set rngSrc = rngSrc.Offset(1, 0)
Loop Until rngSrc = ""
End Sub

Subtract a textbox value from a cell

I have an inventory sheet.
When a researcher takes a quantity in a specific lot, the quantity is removed first from the stock quantity, the specific row of ComboBox1 in the column #8. It's okay for that part.
When a second quantity is taken and the row of the lot is not empty, I put the data in a row under but I want the quantity (textBox2) to be substract to the column #8 of the row of ComboBox1.
Private Sub CommandButton1_Enter()
Dim emptyRow As Long
Dim ws As Worksheet
Set ws = ActiveSheet
ActiveSheet.Name = "Micrux"
Dim iLastRow As Long, iFound As Long
Dim rng, bEmpty As Boolean, c As Integer
Dim Test As Boolean
bEmpty = True
With ws
iLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A1:A" & iLastRow + 1).Find(ComboBox1.Value, _
After:=.Range("A" & iLastRow + 1), _
LookIn:=xlValues, _
lookat:=xlWhole, _
searchorder:=xlByRows, _
SearchDirection:=xlPrevious)
Test = (TextBox2.Text) > ws.Cells(iLastRow, 8)
If Test = True Then
MsgBox "Not enough quantity in stock!"
Else
If rng Is Nothing Then
iFound = iLastRow + 1
Else
iFound = rng.Row
For c = 4 To 7
If Len(.Cells(iFound, c)) > 0 Then bEmpty = False
Next
If bEmpty = False Then
iFound = iFound + 1
.Cells(iFound, 1).EntireRow.Insert xlShiftDown
.Cells(iFound, 7).Value = TextBox2.Text
.Cells(iFound, 6).Value = TextBox3.Text
.Cells(iFound, 5).Value = ComboBox2.Value
.Cells(iFound, 4).Value = TextBox1.Text
Else
.Cells(iFound, 7).Value = TextBox2.Text
.Cells(iFound, 6).Value = TextBox3.Text
.Cells(iFound, 5).Value = ComboBox2.Value
.Cells(iFound, 4).Value = TextBox1.Text
End If
End If
End If
End With
Unload Me
End Sub

If cell value same with upper cell value

I tried to make macro for my daily job, but i cannot use IF as formula due to so many item in my excel file, so solution is to convert formula to VBA code.
I need help to convert if formula to VBA code in excel as below:
=IF(J2<>J1,AD2-X2,AE1-X2).
Here is an answer to your question. However, it is limited to only work with OP information. Also, if the calculations are taking too long then, you should try setting your calculation to Manual (Formulas->Calculation Options->Manual).
Option Explicit
Public Sub RunIF()
Dim vntOut As Variant
Dim rngSame As Range
With ActiveSheet
Set rngSave = .Range("X2")
If (LCase(Trim(.Range("J2").Value)) <> LCase(Trim(.Range("J1").Value))) Then
vntOut = .Range("AD2").Value - rngSave.Value
Else
vntOut = .Range("AE1").Value - rngSave.Value
End If
.Range("AE2").value = vntOut
Set rngSave = Nothing
End With
End Sub
And here is your code converted to use Column J:
Private Sub CommandButton12_Click()
Dim x As Long
Dim LastRow As Long
Dim i as long
With Sheets("Shipping Schedule")
LastRow = .Cells(.Rows.Count, "J").End(xlUp).Row
For i = 2 to LastRow
set r = .Range("J" & I)
'For Each r In .Range("J2:J" & LastRow)
If LCase(Trim(r.Value)) <> LCase(Trim(r.Offset(-1, 0).Value)) Then
'ae2 = "AD2" - "x2"
r.Offset(0, 21).Value = r.Offset(0, 20).Value - r.Offset(0, 14).Value
Else
'ae2 = "AE1" - "x2"
r.Offset(0, 21).Value = r.Offset(-1, 21).Value - r.Offset(0, 14).Value
End If
set r = nothing
Next i
End With
End Sub
However, you should increment with I instead of for each as the cells are dependent on the previous row and excel may not loop through the range like you would prefer.
Excel Formula to VBA: Fill Column
Sub FillColumn()
Const cCol As Variant = "J" ' Last-Row-Column Letter/Number
Const cCol1 As Variant = "AD"
Const cCol2 As Variant = "X"
Const cCol3 As Variant = "AE"
Const cFirstR As Long = 1 ' First Row
Dim rng As Range ' Last Used Cell in Last-Row-Column
Dim i As Long ' Row Counter
Set rng = Columns(cCol).Find("*", , xlFormulas, , xlByColumns, xlPrevious)
If rng Is Nothing Then Exit Sub
For i = cFirstR To rng.Row - 1
If Cells(i + 1, cCol) <> Cells(i, cCol) Then
Cells(i + 1, cCol3) = Cells(i + 1, cCol1) - Cells(i + 1, cCol2)
Else
Cells(i + 1, cCol3) = Cells(i, cCol3) - Cells(i + 1, cCol2)
End If
Next
End Sub
Private Sub CommandButton12_Click()
Dim x As Long
Dim LastRow As Long
Sheets("Shipping Schedule").Select
With Sheets("Shipping Schedule")
LastRow = .Cells(.Rows.Count, "N").End(xlUp).Row
For Each r In .Range("N2:N" & LastRow)
If r.Value <> "" Then
r.Offset(0, 19).Value = ………………………………….
End if
Next r
End With
End Sub

VBA - looking through each record

Struggling a bit with this code, I haven't ever had to reference one column and copy and paste to another tab in VBA so here goes..
I have an excel document with a table on it similar to below:
I need my code to look in column A find the first name, in this case, Nicola. I then want it to look at column B and check to see if she has the word "Internet" appear in any of the records stored against her, as she does the code will ignore her and move down to the next name on the list, in this case, Graham. It will then look to column B and check if he has the word "Internet". As he doesn't, the code needs to copy the Information from column A & B in relation to this persons name and paste the information into another sheet in the workbook.
Sub Test3()
Dim x As String
Dim found As Boolean
Range("B2").Select
x = "Internet"
found = False
Do Until IsEmpty(ActiveCell)
If ActiveCell.Value = x Then
found = True
Exit Do
End If
ActiveCell.Offset(1, 0).Select
Loop
If found = False Then
Sheets("Groupings").Activate
Sheets("Groupings").Range("A:B").Select
Selection.Copy
Sheets("Sheet1").Select
Sheets("Sheet1").Range("A:B").PasteSpecial
End If
End Sub
Any help would be greatly appreciated.
Thanks
Paula
Private Sub Test3()
Application.ScreenUpdating = False
Set sh1 = Sheets("Groupings") 'data sheet
Set sh2 = Sheets("Sheet1") 'paste sheet
myVar = sh1.Range("D1")
Lastrow = sh1.Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To Lastrow '2 being the first row to test
If Len(sh1.Range("A" & i)) > 0 Then
Set myFind = Nothing
If WorksheetFunction.CountA(sh1.Range("A" & i, "A" & Lastrow)) > 1 Then
If Len(sh1.Range("A" & i + 1)) = 0 Then
nextrow = sh1.Range("A" & i).End(xlDown).Row - 1
Else
nextrow = nextrow + 1
End If
Set myFind = sh1.Range("B" & i, "B" & nextrow).Find(What:=myVar, LookIn:=xlFormulas, LookAt:=xlWhole)
Else
nextrow = Lastrow
Set myFind = sh1.Range("B" & i, "B" & nextrow).Find(What:=myVar, LookIn:=xlFormulas, LookAt:=xlWhole)
End If
If myFind Is Nothing Then
sh1.Range("A" & i, "B" & nextrow).Copy
sh2.Range("A" & sh2.Range("B" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
End If
Next
End Sub
I don't clearly see the structure of your data, but assuming the original data is in Worksheet Data, I think the following is going to do what you want (edited to search for two conditions).
Private Sub Test3()
Dim lLastRow as Long
Dim a as Integer
Dim i as Integer
Dim sText1 As String
Dim sText2 As String
sText1 = Worksheets("Data").Cells(1, 5).Value 'search text #1, typed in E1
sText2 = Worksheets("Data").Cells(2, 5).Value 'search text #2, typed in E2
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
a = 1
For i = 2 To lLastRow
If (Worksheets("Data").Cells(i, 1).Value <> "") Then
If (Worksheets("Data").Cells(i, 2).Value <> sText1 And Worksheets("Data").Cells(i + 1, 2).Value <> sText1 And Worksheets("Data").Cells(i, 2).Value <> sText2 And Worksheets("Data").Cells(i + 1, 2).Value <> sText2) Then
Worksheets("Groupings").Cells(a, 1).Value = Worksheets("Data").Cells(i, 1).Value
Worksheets("Groupings").Cells(a, 2).Value = Worksheets("Data").Cells(i, 2).Value
Worksheets("Groupings").Cells(a, 3).Value = Worksheets("Data").Cells(i + 1, 2).Value
a = a + 1
End If
End If
Next
End Sub

Resources