Change values of blocks of cells in column separated by empty cells - excel

I have a column of data with blocks of non-empty cells followed by blocks of empty cells. See picture below. I'm trying to develop a macro that inserts formulas within each block of non-empty cells and ends when it reaches the last non-empty cell block in the column. What I cannot figure out is how to generalize finding the first and last cell in each non-empty cell block. Perhaps there is some counting method such as firstrow(i) and lastrow(i) Any suggestions are greatly appreciated. Thanks!
Data layout:
Macro:
Sub test()
Dim r As Integer
Dim firstrowX, lastrowX As Long
Dim sht As Worksheet
Set sht = Sheets("Sheet1")
With sht
'first row in block
firstrowX = sht.Cells(3, 12).End(xlDown).Row
'last row in block
lastrowX = sht.Cells(firstrowX, 12).End(xlDown).Row
'last row in column
lastrowCol = sht.Cells(Rows.count, 12).End(xlUp).Row
For r = firstrowX To lastrowX
If r <> lastrowX Then
.Cells(r, 12).FormulaR1C1 = "=IF(RC[-1]=RC[-6],1, IF(R" & lastrowX & "C[]=1, -1, 0))"
Else
.Cells(r, 12).FormulaR1C1 = "=IF(RC[-1]=RC[-6],1,0)"
End If
If lastrowX = lastrowCol Then
Exit Sub
Next r
End With
End Sub

Seeing as you're looping through all cells in that column anyway, you could just use an If block:
For r = firstrowX To lastrowX
If Cells(r, 12).Value <> vbNullString Then
If r <> lastrowX Then
.Cells(r, 12).FormulaR1C1 = "=IF(RC[-1]=RC[-6],1, IF(R" & lastrowX & "C[]=1, -1, 0))"
Else
.Cells(r, 12).FormulaR1C1 = "=IF(RC[-1]=RC[-6],1,0)"
End If
If lastrowX = lastrowCol Then
Exit Sub
End If
Next r
But the easier method would be to use SpecialCells()
Assuming your cells contain constant data as your image suggests:
For Each cell In .Range("L2:L" & .Cells(.Rows.Count, 12).End(xlUp).Row).SpecialCells(xlCellTypeConstants)
If cell.Offset(1, 0).Value = vbNullString Then
cell.FormulaR1C1 = "=IF(RC[-1]=RC[-6],1,0)"
Else
cell.FormulaR1C1 = "=IF(RC[-1]=RC[-6],1, IF(R" & cell.End(xlDown).Row & "C[]=1, -1, 0))"
End If
Next

Use the Range.SpecialCells method. If the cells already contain formulas returning numbers, you can target that subset specifically with the xlCellType Enumeration
Dim lastrowX As Long
With Sheets("Sheet1").Columns(12)
lastrowX = .Cells(Rows.Count, 1).End(xlUp).Row
With .Cells.SpecialCells(xlCellTypeFormulas, xlNumbers)
.FormulaR1C1 = "=IF(RC[-1]=RC[-6],1, IF(R" & lastrowX & "C[]=1, -1, 0))"
End With
.Cells(lastrowX, 1).FormulaR1C1 = "=IF(RC[-1]=RC[-6],1,0)"
End With

This one isn't as compact as the others, but it's written similar to yours. You can step through it to see how the formula works:
Sub example()
Application.ScreenUpdating = False
With ActiveSheet
lastRow = .Cells(.Rows.Count, 12).End(xlUp).row
'lastRow = .UsedRange.Rows.Count
End With
Dim Column2Copy As String
Column2Copy = "L"
Dim startCell As Range
Set startCell = Cells(3, 12).End(xlDown)
Do While startCell.row < lastRow
If startCell.End(xlDown).Offset(-1, 0).row > lastRow Then
newLastRow = lastRow
Else
newLastRow = startCell.End(xlDown).Offset(-1, 0).row
End If
If newLastRow > lastRow Then
Range(Cells(startCell.row, Column2Copy), Cells(newLastRow, Column2Copy)).FormulaR1C1 = "=IF(RC[-1]=RC[-6],1, IF(R" & lastRow & "C[]=1, -1, 0))"
Else
Range(Cells(startCell.row, Column2Copy), Cells(newLastRow, Column2Copy)).FormulaR1C1 = "=IF(RC[-1]=RC[-6],1,0)"
End If
Set startCell = startCell.End(xlDown)
Loop
Application.ScreenUpdating = True
End Sub

Related

VBA, If all rows in Col A is filled and Col B is blank(and vice versa) then copy those rows to a new sheet

I am trying to incorporate the following logic, If all rows in Col A is filled and Col B is blank(and vice versa) then copy those rows to a new sheet.
Here is what I have so far:
Sub DataValidation()
Dim rng As Range
Dim cell As Range
Set rng = Range("A:B")
For Each cell In rng
If Cel.Value = "" Then
Sheets("List").Cel.Value.EntireRow.Copy Destination:=Sheets("test").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next cell
End Sub
Can anyone help with this?
I need help with 1) If.Cel.Value="" , I dont think this identifies the logic for Col A filled and Col B is blank. 2) And I need help identifying these rows and copying to a new tab.
Latest code:
Sub DataValidationTwo()
Dim ws As Worksheet, lastR As Long, arr, rngCopy As Range, i As Long
Set ws = ActiveSheet
lastR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
arr = ws.Range("AU4:AV" & lastR).Value2 'place the range in an array for faster iteration/processing
For i = 4 To UBound(arr) '4 supposing that headers exist on the third row
If (arr(i, 1) <> "" And arr(i, 2) = "") Or (arr(i, 2) <> "" And arr(i, 1) = "") Then
addToRange rngCopy, ws.Range("A" & i)
End If
Next i
If Not rngCopy Is Nothing Then rngCopy.EntireRow.Copy _
Sheets("test").Range("A" & Rows.Count).End(xlUp).Offset(1)
MsgBox "Complete"
End Sub
new code. It is only pasting row 4 to test. It should paste more of my test rows over.
Sub DataValidationTwo()
Dim ws As Worksheet, lastR As Long, arr, rngCopy As Range, i As Long
With Sheets("test")
.Rows(2 & ":" & .Rows.Count).Delete
End With
Set ws = ActiveSheet
'Set ws = Sheets("ATP List")
lastR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
arr = ws.Range("AU4:AV" & lastR).Value2 'place the range in an array for faster iteration/processing
For i = 4 To UBound(arr) '4 supposing that headers exist on the third row
If (arr(i, 1) <> "" And arr(i, 2) = "") Or (arr(i, 2) <> "" And arr(i, 1) = "") Then
addToRange rngCopy, ws.Range("A" & i)
End If
Next i
If Not rngCopy Is Nothing Then rngCopy.EntireRow.Copy _
Sheets("test").Range("A" & Rows.Count).End(xlUp).Offset(1)
MsgBox "Complete"
End Sub
First off, your reference to cell.value has a typo, it needs to be cell.value
As for the solution, just like Bigben said, a Range.AutoFilter is probably the simplest option here without Advanced Filters.
You'll be looking for something like this
rng.AutoFilter Field:=1, Criteria1:="<>" 'This will filter by non-blanks in Column 1
rng.AutoFilter Field:=2, Criteria1:="=" 'This will filter by blanks in Column 2
When a range is filtered, if you use rng, it will still refer to the entire range including those hidden (essentially ignoring the filter). This is why you should now use rng.specialCells(xlCellTypeVisible) to now refer to the displaying range.
Mix and match filters and then use rng.specialCells(xlCellTypeVisible).Copy
Please, try the next way. It uses an array and builds a Union range, to be copied at the code end. That's why is should be much faster than iterating between all cells and copying a row at a time:
Sub DataValidation()
Dim ws As Worksheet, lastR As Long, arr, rngCopy As Range, i As Long
Set ws = ActiveSheet
lastR = ws.Range("A" & ws.rows.count).End(xlUp).row
arr = ws.Range("AU4:AV" & lastR).Value2 'place the range in an array for faster iteration/processing
For i = 2 To UBound(arr) '2 supposing that headers exist on the first row
If (arr(i, 1) <> "" And arr(i, 2) = "") Or (arr(i, 2) <> "" And arr(i, 1) = "") Then
addToRange rngCopy, ws.Range("A" & i)
End If
Next i
If Not rngCopy Is Nothing Then rngCopy.EntireRow.Copy _
Sheets("test").Range("A" & rows.count).End(xlUp).Offset(1)
End Sub
Sub addToRange(rngU As Range, rng As Range)
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End Sub

Move duplicates rows above

I have sheet1 and sheet10 to run a macro to find duplicates comparing column A and B.
Highlight color duplicates, in column A, move duplicates to first row A1.
Any help will appreciate, thank you in advance.
Macro need to run in sheet 1 and sheet 10 maybe less sheets.
Sub sbFindDuplicatesInColumn()
Dim lastRow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long
lastRow = Range("A1:C").End(xlUp).Row
For iCntr = 1 To lastRow
If Cells(iCntr, 1) <> "" Then
matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" & lastRow), 0)
If iCntr <> matchFoundIndex Then
Cells(iCntr, 2) = "Duplicate"
End If
End If
Next
End Sub
Build a range of the duplicate cells using Union, copy and insert them in the first row and then delete them.
Sub sbFindDuplicatesInColumn2()
Const DUP_COLOR = &H9696FF ' pink
Dim ws, rngDup As Range, c As Range
Dim arC, v, sht, lastRow As Long, n As Long
For Each sht In Array("Sheet1", "Sheet10")
Set ws = Sheets(sht)
n = 0
With ws
.Cells.ClearFormats
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
arC = .Range("C1:C" & lastRow) ' array
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Each c In .Range("A1:A" & lastRow)
v = Application.Match(c.Value2, arC, 0)
If Not IsError(v) Then
.Cells(v, "C").Interior.Color = DUP_COLOR
If n = 0 Then
Set rngDup = c
Else
Set rngDup = Application.Union(rngDup, c)
End If
n = n + 1
End If
Next
' move cells and sort
If n > 0 Then
' copy to top
.Range("A1").Resize(n).Insert shift:=xlDown
rngDup.Copy .Range("A1")
.Range("A1:A" & n).Interior.Color = DUP_COLOR
' delete
rngDup.Delete shift:=xlUp
' sort
With .Sort
.SetRange ws.Range("A1:A" & n)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If
End With
MsgBox n & " Duplicates found in " & ws.Name, vbInformation
Next
End Sub
You should add comparing the values of ranges
Sub sbFindDuplicatesInColumn()
Dim lastRow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long
lastRow = Range("A1:C").End(xlUp).Row
For iCntr = 1 To lastRow
If Cells(iCntr, 1) <> "" Then
matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" & lastRow), 0)
If iCntr <> matchFoundIndex AND Cells(iCntr,1).Value <> Range("A1:A" & lastRow).Value
Then
Cells(iCntr, 2) = "Duplicate"
End If
End If
Next
End Sub

Loop, find cells with value then search column for the same cell and change its value

Detailed Problem
I'm attempting to write a VBA code that would loop through Column D,
if it finds Cells(i,"D") = "Good" then the code would search the entire column D for that value in cells (i,"D") and change all it's value to "Good"
Here is an Image on before the code.
Here is an Image after the code.
My Attempt:
Dim i As Integer
For i = 1 To Rows.Count
If Cells(i, "m") = "Good" Then
x = Cells(i, "m")
Next i
I think you would have to store the value ( ID Number ) and then search for it which I assigned "X". Once "X" is found change the status to "Good"
Use an AutoFilter
Option Explicit
Sub makeGood()
Dim i As Long, tmp As Variant
Dim dict As Object, k As Variant
'late bind a dictionary
Set dict = CreateObject("scripting.dictionary")
dict.CompareMode = vbTextCompare
With Worksheets("sheet11")
'remove any existing autofilters
If .AutoFilterMode Then .AutoFilterMode = False
'collect values from column D
tmp = .Range(.Cells(2, "D"), .Cells(.Rows.Count, "D").End(xlUp)).Value
'build dictionary of unique ID NUMs
For i = LBound(tmp, 1) To UBound(tmp, 1)
dict.Item(tmp(i, 1)) = vbNullString
Next i
'work with D:G range
With .Range(.Cells(1, "D"), .Cells(.Rows.Count, "G").End(xlUp))
'loop through unique ID NUMs
For Each k In dict.Keys
'autofilter on key
.AutoFilter field:=1, Criteria1:=k, visibledropdown:=False
'autofilter on Good
.AutoFilter field:=4, Criteria1:="good", visibledropdown:=False
'check for visible cells
If Application.Subtotal(103, .Offset(1, 0).Cells) > 0 Then
'remove the Good autofilter
.AutoFilter field:=4
'step down off the header and put Good in the filtered cells
With .Resize(.Rows.Count - 1, 1).Offset(1, 3)
.SpecialCells(xlCellTypeVisible) = "Good"
End With
End If
'clear autofilter
.AutoFilter field:=1
.AutoFilter field:=4
Next k
End With
End With
End Sub
May be a bit convoluted, but here is an idea.
Sub f(strSearchFor as string)
Dim r As Excel.Range
Dim d As New Scripting.Dictionary
Set r = Range("a1:b10")
For Each c In r.Columns(2).Cells
If StrComp(c.Value, strSearchFor, vbTextCompare) = 0 Then
If Not d.Exists(c.Value) Then
d.Add c.Offset(0, -1).Value, c.Value
End If
End If
Next c
For Each c In r.Columns(1).Cells
If d.Exists(c.Value) Then
c.Offset(0, 1).Value = d(c.Value)
End If
Next c
Set r = Nothing
Set d = Nothing
End Sub
You can add a helper column and do it with a formula only:
Add the following formula eg. in H2 (of your example) and pull it down:
=IF(COUNTIFS(D:D,D2,G:G,"Good")>0,"Good",G2)
You could try:
Option Explicit
Sub trst()
Dim i As Long, y As Long, LastRow As Long
Dim ID As String, Status As String
With ThisWorkbook.Worksheets("Sheet1") '<- Change Workbook / Sheet names
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
ID = .Range("D" & i).Value
Status = .Range("G" & i).Value
For y = 2 To LastRow
If ID = .Range("D" & y).Value Then
.Range("G" & y).Value = Status
End If
Next y
Next i
End With
End Sub
Test with arrais. With arrais it is much faster
Option Explicit
Sub Subst()
With ThisWorkbook.Sheets("Sheet1")
Dim ArrayColumnD As Variant
ArrayColumnD = .Range("D1:D" & .Cells(.Rows.Count, 4).End(xlUp).Row)
Dim ArrayColumnG As Variant
ArrayColumnG = .Range("G1:G" & .Cells(.Rows.Count, 7).End(xlUp).Row)
Dim ID As String
Dim RowActual As Long
Dim RowTest As Long
For RowActual = 2 To UBound(ArrayColumnD)
If ArrayColumnG(RowActual, 1) = "Good" Then
ID = ArrayColumnD(RowActual, 1)
For RowTest = 2 To UBound(ArrayColumnD)
If ArrayColumnD(RowTest, 1) = ID Then
ArrayColumnG(RowTest, 1) = "Good"
End If
Next RowTest
End If
Next RowActual
.Range("G1:G" & .Cells(.Rows.Count, 7).End(xlUp).Row) = ArrayColumnG
End With
End Sub

How to simplify macros

I'm new here and to the world of VBA.
I've been asked to create a spreadsheet which a user can enter a task number of a job they have been given, from this auto populate other columns with data from a master list, and then when they change the status of the job the row changes colour.
I know that this is easy to do using the vlookup function as a formula in each cell and conditional formatting.
I have searched the web and have found differnt macros that can do the job, but some of them take far to long to find a match, the master task list can contain upto 3000 items.
So I've very crudely cobbled together something that works and quickly.
I was wondering how I can clean these macros up as I'm sure the way I've done it will cause problems in the future or if there is a better way to do the job.
Also as a secoundry question is there any way to get a message box to pop up if the number the user enters doesn't match anything on the master list.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim Status As Range
Set KeyCells = Range("B1:B700") 'Range Looking for Change
Set Status = Range("K1:K700")
Application.ScreenUpdating = False
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
Dim SourceLastRow As Long
Dim OutputLastRow As Long
Dim sourceSheet As Worksheet
Dim outputSheet As Worksheet
Set sourceSheet = Worksheets("Task List")
Set outputSheet = Worksheets("2016")
'Determine last row of Task List
With sourceSheet
SourceLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
With outputSheet
'Determine last row in col B
OutputLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
'Put formula in relevant cell
.Range("F2:F" & OutputLastRow).Formula = _
"=VLOOKUP(B2,'Task List'!$A$2:$D$" & SourceLastRow & ",2,0)"
End With
With outputSheet
OutputLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range("H2:H" & OutputLastRow).Formula = _
"=VLOOKUP(B2,'Task List'!$A$2:$D$" & SourceLastRow & ",3,0)"
End With
With outputSheet
OutputLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range("G2:G" & OutputLastRow).Formula = _
"=VLOOKUP(B2,'Task List'!$A$2:$D$" & SourceLastRow & ",4,0)"
End With
End If
If Not Application.Intersect(Status, Range(Target.Address)) _
Is Nothing Then
Dim n As Long
iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
For n = iLastRow To 1 Step -1
If Cells(n, "K").Value = "Closed" Then
Rows(n).Interior.Color = RGB(57, 255, 20)
End If
If Cells(n, "K").Value = "Bond" Then
Rows(n).Interior.Color = RGB(249, 255, 1)
End If
If Cells(n, "K").Value = "Eng Bond" Then
Rows(n).Interior.Color = RGB(255, 102, 0)
End If
If Cells(n, "K").Value = "Fail" Then
Rows(n).Interior.Color = RGB(255, 1, 1)
End If
If Cells(n, "K").Value = "" Then
Rows(n).Interior.ColorIndex = 2
End If
Next n
End If
Application.ScreenUpdating = True
End Sub

An Excel code to search data from command button

I have tried to make a button which searches through a selection of data on one sheet for a ID number then returns the corresponding data in the row after onto a different sheet. I thought i had it sorted but this just wont work and have run out ideas.
Any help would be appreciated.
see code below:
Private Sub CommandButton2_Click()
Dim Userentry As String
Dim DataRange As Range
Dim i As Long
Dim location As Integer
Dim ws, ws1 As Worksheet
Set ws = Sheets("Sheet1")
Set ws1 = Sheets("Sheet4")
With TextBox2
Userentry = .Value
End With
Range("A36").Value = Userentry
For i = 2 To ws.Range("A" & Rows.Count).End(xlUp).Row
If LCase(Cells(i, 1).Value) = Userentry Then ws1.Range("F" & Rows.Count).End(xlUp).Offset(1, 0).Value = Cells(i, 2).Value
Next i
For i = 2 To ws.Range("A" & Rows.Count).End(xlUp).Row
If LCase(Cells(i, 1).Value) = Userentry Then ws1.Range("G" & Rows.Count).End(xlUp).Offset(1, 0).Value = Cells(i, 3).Value
Next i
For i = 2 To ws.Range("A" & Rows.Count).End(xlUp).Row
If LCase(Cells(i, 1).Value) = Userentry Then ws1.Range("H" & Rows.Count).End(xlUp).Offset(1, 0).Value = Cells(i, 4).Value
Next i
For i = 2 To ws.Range("A" & Rows.Count).End(xlUp).Row
If LCase(Cells(i, 1).Value) = Userentry Then ws1.Range("I" & Rows.Count).End(xlUp).Offset(1, 0).Value = Cells(i, 5).Value
Next i
End Sub
I'd throw in two possible solutions, with the goal to minimize execution time (should it be an issue)
solution 1
here you're still actually looping through column A cells but:
only if there's at least one matching value
considering non empty cells with text values only
`
Option Explicit
Private Sub CommandButton2_Click()
Dim Userentry As String, firstAddr As String
Dim ws1 As Worksheet
Dim f As Range
Set ws1 = Sheets("Sheet4")
Userentry = TextBox2.Value
ws1.Range("A36").Value = Userentry
With Sheets("Sheet1")
With .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlTextValues)'<~~ consider column "A" cells with text values down to the LAST non empty one
Set f = .Find(What:=Userentry, LookAt:=xlWhole, LookIn:=xlValues)
If Not f Is Nothing Then '<~~ loop only if there's at least one matching value
firstAddr = f.Address
Do
ws1.Range("F" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 4).Value = _
f.Offset(, 1).Resize(1, 4).Value
Set f = .FindNext(f)
Loop While f.Address <> firstAddr
End If
End With
End With
End Sub
`
solution 2
this avoids looping at all, but at the "expense" of sorting rows
Option Explicit
Private Sub CommandButton2_Click()
Dim Userentry As String
Dim countVal As Long
Dim ws1 As Worksheet
Set ws1 = Sheets("Sheet4")
Userentry = TextBox2.Value
ws1.Range("A36").Value = Userentry
With Sheets("Sheet1")
With .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<~~ consider column "A" cells down to the LAST non empty one
countVal = Application.WorksheetFunction.CountIf(.Cells, Userentry) '<~~ count matching values
If countVal > 0 Then '<~~ if any then ...
.Resize(, 5).Sort key1:=.Range("A1"), order1:=xlDescending, Header:=xlNo '<~~ ... sort columns "A" to "E" by column "A" values...
ws1.Range("F" & Rows.Count).End(xlUp).Offset(1, 0).Resize(countVal, 4).Value = .Find(What:=Userentry, LookAt:=xlWhole, LookIn:=xlValues).Offset(, 1).Resize(countVal, 4).Value '<~~ ... and copy/paste values
End If
End With
End With
End Sub
if you should ever mind having Sheet1 rows sorted, then here's the "patch"
Private Sub CommandButton2_Click()
Dim Userentry As String
Dim countVal As Long
Dim ws1 As Worksheet
Dim helperCol As Range
Set ws1 = Sheets("Sheet4")
Userentry = TextBox2.Value
ws1.Range("A36").Value = Userentry
With Sheets("Sheet1")
Set helperCol = .UsedRange.Columns(.UsedRange.Columns.Count + 1) '<~~ set a helper column "out of the town" not to interfere with data already there
With .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<~~ consider column "A" cells down to the LAST non empty one
countVal = Application.WorksheetFunction.CountIf(.Cells, Userentry) '<~~ count matching values
If countVal > 0 Then '<~~ if any then ...
With Intersect(.Rows.EntireRow, helperCol) '<~~ consider helper column rows corresponding to your data ones
.Formula = "=ROW()" '<~~ place an ascending index to every row
.Value = .Value '<~~ get rid of formulas, otherwise subsequent sorting would have no effect on their result
End With
.Resize(, helperCol.Column).Sort key1:=.Range("A1"), order1:=xlDescending, Header:=xlNo '<~~ ... sort columns "A" to "helpercol" rows by column "A" values...
ws1.Range("F" & Rows.Count).End(xlUp).Offset(1, 0).Resize(countVal, 4).Value = .Find(What:=Userentry, LookAt:=xlWhole, LookIn:=xlValues).Offset(, 1).Resize(countVal, 4).Value '<~~ ... copy/paste values ...
.Resize(, helperCol.Column).Sort key1:=helperCol, order1:=xlAscending, Header:=xlNo '<~~ ... and sort columns "A" to "helpercol" rows back by "helpercol" values
helperCol.Clear '<~~ finally clear "helpercol" column
End If
End With
End With
End Sub
Private Sub CommandButton2_Click()
Dim Userentry As String
Dim i As Long
Dim ws, ws1 As Worksheet
Set ws = Sheets("Sheet1")
Set ws1 = Sheets("Sheet4")
Userentry = TextBox2.Value
ws1.Range("A36").Value = Userentry
For i = 2 To ws.Range("A" & Rows.Count).End(xlUp).Row
If LCase(ws.Cells(i, 1).Value) = Userentry Then
ws1.Range("F" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 4).Value = _
ws.Cells(i, 2).resize(1, 4).Value
End If
Next i
End Sub

Resources