Is it possible to search for a specific value in a column?
I want to be able to search all of the cells in column "B" and look for the 'word' "pip" in it (without being case sensitive). I've got everything else, just need to know if this is possible or how it can be done.
My Current code looks as follows:
Sub A()
ActiveSheet.Name = "Data"
Dim ws As Worksheet
Set ws = Sheets("Data")
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws1.Name = "pip"
ws.Activate
Row = 2
Dim i As Integer
For i = 1 To 10
If (Cells(i, 2).Value = (HAS pip IN IT) Then 'This is the part that i'm struggling with
Copied = ws.Range(Cells(i, 1), Cells(i, 17)).Value 'If possible, this would cut and paste so it deleted the original
ws1.Activate
ws1.Range(Cells(Row, 1), Cells(Row, 17)).Value = Copied
Row = Row + 1
ws.Activate
End If
Next i
End Sub
Edit: Just to clarify, the value in column B will never just be "pip". It will be a full sentence but if it contains "pip" then i would like the IF function to work.
Find and FindNext work nicely (and quickly!)
'...
Dim copyRange As Range
Dim firstAddress As String
Set copyRange = ws.Range("B1:B1500").Find("pip", , , xlPart)
If Not copyRange Is Nothing Then
firstAddress = copyRange.Address
Do
ws2.Range(Cells(Row, 1), Cells(Row, 17)).Value = Intersect(copyRange.EntireRow, ws.Columns("A:Q")).Value
Row = Row + 1
Set copyRange = Range("B1:B10").FindNext(copyRange)
Loop While copyRange.Address <> firstAddress
End If
'...
Related
all.
I'm running this code:
Sub ISN_Flyer_Performance()
Dim FlyerSh As Worksheet
Dim QlikSh As Worksheet
Dim SKURng As Range
Dim QlikSKURng As Range
Dim SKU As Range
Dim qlr As Long
Dim QlikSKU As Range
Dim TotalSales As Double
Dim FirstQlikSku As Range
Set FlyerSh = ActiveSheet
i = 2
lr = FlyerSh.Range("A" & Rows.Count).End(xlUp).Row
Set QlikSh = Application.InputBox("Click any cell on the Qlikview Sheet you want to lookup against", "Find Qlikview Sheet", Type:=8).Worksheet
qlr = QlikSh.Range("A" & Rows.Count).End(xlUp).Row
Set QlikSKURng = Range(Cells(2, QlikSh.Rows(1).Find(What:="Item Number", LookAt:=xlWhole).Column), Cells(qlr, QlikSh.Rows(1).Find(What:="Item Number", LookAt:=xlWhole).Column))
Set SKURng = Range(FlyerSh.Cells(i, 1), FlyerSh.Cells(lr, 1))
Set SKU = FlyerSh.Cells(i, 1)
For Each SKU In SKURng
Set QlikSKU = QlikSKURng.Find(What:=SKU.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If QlikSKU Is Nothing Then
SKU.Offset(0, 2).Value = 0
GoTo NextSku
Else
TotalSales = QlikSKU.Offset(0, 5).Value
Set FirstQlikSku = QlikSKU
Do
Set QlikSKU = QlikSKURng.FindNext(QlikSKU)
If QlikSKU.Address = FirstQlikSku.Address Then Exit Do
TotalSales = TotalSales + QlikSKU.Offset(0, 5).Value
Loop
SKU.Offset(0, 2) = TotalSales
End If
NextSku:
Next SKU
End Sub
It's essentially like an XLookup, where it gets the thing to seach on one workbook, then finds it on a second, sends the value back to the first one, and moves on to the next item. I'd use an XLookup, but unfortunately, my sheet will always have duplicates, and I need to count both.
So I'm using this findnext loop to loop through a range (QlikSKURange) which has about 16k rows. The findNext is reasonably quick, like less than a second, EXCEPT the last instance when it goes back to the beginning and finds the first instance again. That instance can take over ten seconds.
Any idea why that might be?
Let me know if you need more info about the code.
I tried to just "Find" after the current iteration, instead of find next, and it has the same slow down.
VBA Lookup Using the Find Method
This is just the basic idea. There are many flaws e.g. if you cancel the input box, if you select a 'wrong' worksheet (e.g. column header not found), if there are error values, blank cells, etc.
Option Explicit
Sub ISN_Flyer_Performance()
' Flyer
Dim fws As Worksheet: Set fws = ActiveSheet ' improve!
Dim fLR As Long: fLR = fws.Range("A" & fws.Rows.Count).End(xlUp).Row
Dim frg As Range
Set frg = fws.Range(fws.Cells(2, "A"), fws.Cells(fLR, "A"))
'Debug.Print fws.Name, fLR, frg.Address
' Qlikview
Dim qws As Worksheet: Set qws = Application.InputBox( _
"Click any cell on the Qlikview Sheet you want to lookup against", _
"Find Qlikview Sheet", Type:=8).Worksheet
Dim qLR As Long: qLR = qws.Range("A" & qws.Rows.Count).End(xlUp).Row
Dim qC As Long
With qws.Rows(1) ' assuming that "Item Number" is surely in the first row
qC = .Find("Item Number", .Cells(.Cells.Count), _
xlFormulas, xlWhole).Column
End With
Dim qrg As Range
Set qrg = qws.Range(qws.Cells(2, qC), qws.Cells(qLR, qC))
'Debug.Print qws.Name, qLR, qC, frg.Address
Application.ScreenUpdating = False
Dim fCell As Range
Dim qCell As Range
Dim qFirstAddress As String
Dim TotalSales As Double
' Loop.
For Each fCell In frg.Cells
Set qCell = qrg.Find(fCell.Value, qrg.Cells(qrg.Cells.Count), _
xlFormulas, xlWhole)
If qCell Is Nothing Then
fCell.Offset(0, 2).Value = 0
Else
qFirstAddress = qCell.Address
Do
TotalSales = TotalSales + qCell.Offset(0, 5).Value
Set qCell = qrg.FindNext(qCell)
Loop Until qCell.Address = qFirstAddress
fCell.Offset(0, 2).Value = TotalSales
TotalSales = 0
End If
Next fCell
Application.ScreenUpdating = True
MsgBox "Lookup done.", vbInformation
End Sub
After doing more digging, someone suggested that the issue was that one of my sheets was a table. It had filters on the header row. I removed those (and conditional formatting on a row to find duplicates, and my code ran in a matter of seconds. After isolating those two, turns out the conditional formatting was the culprit.
I am attempting to compare two columns in two separate sheets, each column contains data that is a string. My issue is that there is data in one column that is identical to the other in separate rows; therefore I have to check the entire column for the data before moving to the next. I am very inexperienced with VBA and am trying to make one portion of my job easier rather than comparing the columns by hand. I have piece wised the following code from research and trial and error. I am able to get the entire Column searched in my first Sheet, but only one value is being highlighted on the second sheet and then it is returning a value of "True" in the first column. I am unsure where I have gone wrong, any help is greatly appreciated!
Sub Better_Work_This_Time()
Dim FindString As String
Dim Rng As Range
ActiveCell = Sheets("Last Week").Range("A2").Activate
FindString = ActiveCell
Dim County As Integer
Count = Cells.CurrentRegion.rows.Count
For i = 2 To County
If Trim(FindString) <> "" Then
With Sheets("Current Week").Range("A:A")
Set Rng = .Find(What:=FindString, After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
If Not Rng Is Nothing Then
ActiveCell.Font.Color = vbBlue
End If
End With
End If
If IsEmpty(FindString) Then
FindString = False
End If
ActiveCell.Offset(1, 0).Select
i = i + 1
Next
End Sub
Without using ActiveCell and using Match instead of Find.
Option Explicit
Sub Does_Work_This_Time()
Dim wb As Workbook, wsLast As Worksheet, wsCurrent As Worksheet
Dim FindString As String, ar, v
Dim LastRow As Long, i As Long, n As Long
Set wb = ThisWorkbook
' put current week values into array
Set wsCurrent = wb.Sheets("Current Week")
With wsCurrent
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
ar = .Range("A2:A" & LastRow).Value2
End With
' scan last week matching current week
Set wsLast = wb.Sheets("Last Week")
With wsLast
.Columns(1).Interior.Color = xlNone
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
FindString = Trim(.Cells(i, "A"))
If Len(FindString) > 0 Then
v = Application.Match(FindString, ar, 0)
If IsError(v) Then
'no match
ElseIf ar(v, 1) = FindString Then ' case match
.Cells(i, "A").Interior.Color = RGB(128, 255, 128) ' light green
n = n + 1
End If
End If
Next
End With
MsgBox n & " rows matched"
End Sub
Hey I'm currently writing a macro in VBA (which I'm quite new at). The macro looks at a spreadsheet and finds specific column headers. It then clears the contents of any cell containing a zero. This part of my code works exactly how I want, the only issue is that it does not hand multiple occurrences of the column header...so it finds the first header, clears the contents, and ignores the second occurrence. I have tried multiple avenues whether it be looping to find it or using the .FindNext function. Any help would be appreciated. Thank you! My code is posted below:
Sub DeleteRows2()
Application.ScreenUpdating = True
Dim lastrow As Long
With ActiveSheet
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'~~>Start of First Instance
'~~>dim variables and set initial values
Dim delaymaxheader As Range
Set delaymaxheader = Worksheets(ActiveSheet.Name).Range("A4:Z4").Find(what:="DELAY Spec Max", LookAt:=xlWhole, MatchCase:=False)
Dim delaymaxcolumn As Range
Set delaymaxcolumn = Range(Cells(5, delaymaxheader.Column), Cells(lastrow, delaymaxheader.Column))
'Set delaymaxcolumn = Range(delaymaxheader.Offset(1, 0), delaymaxheader.End(xlDown))
'~~>dim variables and set initial values
Dim delayminheader As Range
Set delayminheader = Worksheets(ActiveSheet.Name).Range("A4:Z4").Find(what:="DELAY Spec Min", LookAt:=xlWhole, MatchCase:=False)
Dim delaymincolumn As Range
Set delaymincolumn = Range(Cells(5, delayminheader.Column), Cells(lastrow, delayminheader.Column))
'Set delaymincolumn = Range(delayminheader.Offset(1, 0), delayminheader.End(xlDown))
'~~>dim variables and set initial values
Dim phasemaxheader As Range
Set phasemaxheader = Worksheets(ActiveSheet.Name).Range("A4:Z4").Find(what:="PHASE Spec Max", LookAt:=xlWhole, MatchCase:=False)
Dim phasemaxcolumn As Range
Set phasemaxcolumn = Range(Cells(5, phasemaxheader.Column), Cells(lastrow, phasemaxheader.Column))
'Set phasemaxcolumn = Range(phasemaxheader.Offset(1, 0), phasemaxheader.End(xlDown))
'~~>dim variables and set initial values
Dim phaseminheader As Range
Set phaseminheader = Worksheets(ActiveSheet.Name).Range("A4:Z4").Find(what:="PHASE Spec Min", LookAt:=xlWhole, MatchCase:=False)
Dim phasemincolumn As Range
Set phasemincolumn = Range(Cells(5, phaseminheader.Column), Cells(lastrow, phaseminheader.Column))
'Set phasemincolumn = Range(phaseminheader.Offset(1, 0), phaseminheader.End(xlDown))
'~~>Loop to delete rows with zero
'~~>Dim delaycount(5 To lastrow) As Integer
For i = 5 To lastrow
If Cells(i, delaymaxheader.Column) = 0 Then
Cells(i, delaymaxheader.Column).ClearContents
End If
If Cells(i, delayminheader.Column) = 0 Then
Cells(i, delayminheader.Column).ClearContents
End If
If Cells(i, phasemaxheader.Column) = 0 Then
Cells(i, phasemaxheader.Column).ClearContents
End If
If Cells(i, phaseminheader.Column) = 0 Then
Cells(i, phaseminheader.Column).ClearContents
End If
Next i
End Sub
You need to use the FindNext method to keep going (https://msdn.microsoft.com/en-us/library/office/ff839746.aspx)
LastRow is only the last row of column A though - what happens if another column goes further?
Also Worksheets(ActiveSheet.Name).Range("A4:Z4") is the same as ActiveSheet.Range("A4:Z4").
Public Sub DeleteRows()
Dim colAllRanges As Collection
Dim colHeadings As Collection
'Declared as variants as they're used to step through the collection.
Dim vHeading As Variant
Dim vRange As Variant
Dim vCell As Variant
Dim rDelayMaxHeader As Range
Dim sFirstAddress As String
Dim lLastRow As Long
With ActiveSheet
lLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set colAllRanges = New Collection
Set colHeadings = New Collection
colHeadings.Add "DELAY Spec Max"
colHeadings.Add "DELAY Spec Min"
colHeadings.Add "PHASE Spec Max"
colHeadings.Add "PHASE Spec Min"
For Each vHeading In colHeadings
With ActiveSheet.Range("A4:Z4")
'Find the first instance of the heading we're looking for.
Set rDelayMaxHeader = .Find(What:=vHeading, LookIn:=xlValues, LookAt:=xlWhole)
If Not rDelayMaxHeader Is Nothing Then
sFirstAddress = rDelayMaxHeader.Address
Do
'Resize the range from heading to last row and add it to the collection.
colAllRanges.Add rDelayMaxHeader.Resize(lLastRow - rDelayMaxHeader.Row + 1, 1)
'Find the next occurrence.
Set rDelayMaxHeader = .FindNext(rDelayMaxHeader)
'Keep going until nothings found or we loop back to the first address again.
Loop While Not rDelayMaxHeader Is Nothing And rDelayMaxHeader.Address <> sFirstAddress
End If
End With
Next vHeading
'Now to go through each cell in the range we've added to the collection and check for 0's.
For Each vRange In colAllRanges
For Each vCell In vRange
If vCell = 0 Then
vCell.ClearContents
End If
Next vCell
Next vRange
End Sub
With the above method you can add extra columns if needed - just add another colHeadings.Add "My New Column Header" row in the code.
I pasted the entire macro below but this is the important part.
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Range("D2:D10000").Value = Range("D2").Offset(-1, 1).Value
Range("F2:F10000").Value = Range("F2").Offset(-1, 1).Value
Range("H2:H10000").Value = Range("H2").Offset(-1, 1).Value
It works as is except it is creating unnecessary data because I don't know how to use variable names in a range object. My ranges are currently hard coded such as ("A1:A1000"), when I would like it to be something like ("A1:A & LastRow).
Also I have to explicitly call out column names to copy because the range won't accept a variable name like ("currentColumn & 1:currentColumn & LastRow).
Is there a way to use a varible name as part of a range object so we can use them in loops?
Sub prepareWorkbook()
Dim wbk As Workbook
Set wbk = ThisWorkbook
Dim wks As Worksheet
Set wks = wbk.ActiveSheet
Dim colx As Long
Dim ColumnCount As Long
Dim MySheetName As String
MySheetName = "Import"
LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
ActiveSheet.Name = MySheetName
'identify the Id column and move it to 1st column
Dim answer As Variant
Dim IdColumn As Range
answer = Application.InputBox("Enter Letter of Id column")
If Columns(answer).Column = 1 Then
Else
'cut Id column from current location and insert it at column index 1
Columns(answer).Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
End If
'trim the PartNumber column of any trailing spaces
Dim c As Range
For Each c In Range("A1:A10000")
c.Value = Application.Trim(Replace(c.Value, Chr(160), Chr(32)))
Next
' insert column every other column
' Loop through number of columns.
ColumnCount = Application.WorksheetFunction.CountA(Rows(1)) * 2
'step 2 means skip every other
For colx = 2 To ColumnCount Step 2
Columns(colx).Insert Shift:=xlToRight
Next
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Range("D2:D10000").Value = Range("D2").Offset(-1, 1).Value
Range("F2:F10000").Value = Range("F2").Offset(-1, 1).Value
Range("H2:H10000").Value = Range("H2").Offset(-1, 1).Value
wks.Cells.EntireColumn.AutoFit
MsgBox ("Done")
End Sub
Assuming the you are running code in the Worksheet added here:
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
ActiveSheet.Name = MySheetName
Also not sure what is the purpose of this code, nevertheless using it for the sample
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Try this:
Dim lLastRow As Long
lLastRow = wbk.Worksheets(MySheetName).UsedRange.SpecialCells(xlLastCell).Row
Rem This updates only columns B, D, F & H - adjust as needed
For colx = 2 To 8 Step 2
With wbk.Worksheets(MySheetName)
Rem Creates Range as Range(Cells(rIni,cIini), Cells(rEnd,cEnd))
rem Corresponding code for "Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value" (see comment above)
Range(.Cells(2, colx), .Cells(lLastRow, colx)) = .Cells(2, colx).Offset(-1, 1).Value
End With: Next
Something like:
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("B2:B" & LastRow).Value = Range("B2").Offset(-1, 1).Value
Range("D2:D" & LastRow).Value = Range("D2").Offset(-1, 1).Value
Range("F2:F" & LastRow).Value = Range("F2").Offset(-1, 1).Value
Range("H2:H" & LastRow).Value = Range("H2").Offset(-1, 1).Value
Although this answer won't be applied to your situation, I feel like this could help answer some questions you have in there.
When specifying a range, you can separate the column (letter) and row (number) and use your own variables.
In a for loop, this could look like
for i = 1 to 100
Range("A" & i).Value = Range("A"&i).Offset(, 1).Value
next
You can also determine the number of the row of the selected cell using:
dim RowNb as long
RowNb = (ActiveCell.Row)
This also applies to columns, and can be used in a loop like I mentionned at the start.
The one thing that was conspicuous by its absence in your description was any mention of the nature of the data in the worksheet. You mentioned A1 briefly but your range value assignments started at row 2 so it may be inferred that row 1 contains column header labels.
Sub prepareWorkbook()
Dim wbk As Workbook, wks As Worksheet
Dim colx As Long
Dim lc As Long, lr As Long
Dim MySheetName As String
Set wbk = ThisWorkbook 'no idea what this does
Set wks = wbk.ActiveSheet 'no idea what this does
MySheetName = "Import"
'no idea what this does or what sht is
'LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
With Sheets(2)
.Name = MySheetName
If CBool(Application.CountIf(.Rows(1), "PartNumber")) Then
colx = Application.Match("PartNumber", .Rows(1), 0)
Else
colx = .Range(Application.InputBox("Enter Letter of Id column") & 1).Column
End If
If .Columns(colx).Column > 1 Then
'cut Id column from current location and insert it at column index 1
.Columns(colx).Cut
.Columns(1).Insert Shift:=xlToRight
End If
'quickest way to trim trailing spaces is with Text-to-Columns, Fixed Width
With .Columns(1)
.TextToColumns Destination:=.Cells(1), DataType:=xlFixedWidth, FieldInfo:=Array(0, 1)
End With
' insert column every other column (working backwards toward A1)
For lc = .Cells(1, Columns.Count).End(xlToLeft).Column To 2 Step -1
.Columns(lc).Insert Shift:=xlToRight
Next lc
For lc = (.Cells(1, Columns.Count).End(xlToLeft).Column - 1) To 2 Step -2
'let's put the row-by-row value in instead of a single value into all cells
lr = .Cells(Rows.Count, lc + 1).End(xlUp).Row
With .Cells(2, lc).Resize(lr - 1, 1)
.Cells = .Offset(-1, 1).Value
.EntireColumn.AutoFit
End With
Next lc
End With
Set wbk = Nothing
Set wks = Nothing
End Sub
Explanations as comments in code.
To be quite honest I am not entirely sure how to describe what it is I am trying to accomplish? But, here it goes anyway. I have an excel sheet containing one column of IDs and a second column of values that need to be associated to the first column. The problem is that the IDs in column A contain duplicates, which is okay because one ID can qualify for multiple values. What I need is to have a third column pull back the unique id, and a fourth column pull back a semi-colon delimited list of all of the values the id qualifies for. Hopefully the attached image makes sense? For what it's worth I have tried every formula I can think of, and I really know nothing about macros, which is what I am thinking needs to be implemented.
Try below code :
Sub sample()
Dim lastRowA As Long, lastRowC As Long
lastRowA = Range("A" & Rows.Count).End(xlUp).Row
lastRowC = Range("C" & Rows.Count).End(xlUp).Row
Dim rng As Range, cell As Range
Set rng = Range("C2:C" & lastRowC)
Dim rngSearch As Range
Set rngSearch = Range("A1:A" & lastRowA)
Dim rngFind As Range
Dim firstCell As String
For Each cell In rng
Set rngFind = rngSearch.Find(What:=cell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rngFind Is Nothing Then
temp = rngFind.Offset(0, 1)
firstCell = rngFind.Address
Do While Not rngFind Is Nothing
Set rngFind = rngSearch.FindNext(After:=rngFind)
If rngFind.Address <> firstCell Then
temp = temp & ";" & rngFind.Offset(0, 1)
Else
Set rngFind = Nothing
End If
Loop
End If
cell.Offset(0, 1) = temp
Next
End Sub
Here's an alternative approach, that has several advantages
it builkds the list of unique sku's
it clear old data from columns C:D
it will run much faster than looping over a range
Sub Demo()
Dim rngA As Range, rng as Range
Dim datA As Variant
Dim i As Long
Dim sh As Worksheet
Dim dic As Object
Set sh = ActiveSheet ' can change this to your worksheet of choice
Set dic = CreateObject("Scripting.Dictionary")
With sh
' Get data from columns A:B into a variant array
Set rngA = .Range(.Cells(2, 2), .Cells(.Rows.Count, 1).End(xlUp))
datA = rngA
' Create list of unique sku's and built value strings
For i = 1 To UBound(datA)
If dic.Exists(datA(i, 1)) Then
dic(datA(i, 1)) = dic(datA(i, 1)) & ";" & datA(i, 2)
Else
dic.Add datA(i, 1), datA(i, 2)
End If
Next
' Clear exisating data from columns C:D
Set rng = .Range(.Cells(2, 4), .Cells(.Rows.Count, 3).End(xlUp))
If rng.Row > 1 Then
rng.Clear
End If
' Put results into columns C:D
.Range(.Cells(2, 3), .Cells(dic.Count + 1, 3)) = Application.Transpose(dic.Keys)
.Range(.Cells(2, 4), .Cells(dic.Count + 1, 4)) = Application.Transpose(dic.Items)
End With
End Sub
How to add this:
Start the VBS editor (Alt+F11 from excel)
show project explorer, if its not already visible (Ctrl+R)
add a Module (right click on your workbook, Insert, Module)
open the module (dbl click)
Add Option Explicit as the first line, if not already there
copy paste this code into module
How to run it, from Excel
activate the sheet with your data
open macro dialog (Alt+F8)
select Demo from list and run